6-r 

CALL RETRY_INIip^KRR) ^^^V 

WRITE(*,390) ^^^^ 

READ (*, *,ERR= 93 90, lOSTAT^I ERR) IGTFtype 

PreCalcGTFs=. FALSE. ! initialize not to use pre-calculated GTFs 

C Note that pre-calculated GTFs already include Earth shadow, 

C since solid Earth is included in the trajectory- tracing calculations. 

C In those cases, Shadow must be set to .FALSE, regardless of user 

C input . 

IF (IGTFtype .NE. 0) THEN 
9391 CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE{*,391) 

READ (*, *,ERR= 93 91, IOSTAT=IERR) IpreCalc 
PreCalcGTFs= . TRUE . 
Shadows . FALSE . 

C Use quiet- time, 51.6 degrees as the default case 

IF (IpreCalc .LT. 0 .OR. IpreCalc .GT. 3) IpreCalc=0 
9427 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (*, 427) 

READ (* , 428 , ERR=9427 , IOSTAT=IERR) GtransFile 
CALL CHECK_OUTPUT_FILE {Gtransf ile , lACCEPT) 
IF ( IACCEPT . NE . 0 ) GOTO 9427 

C For use in SUBROUTINE GTFHeaderOutput . Added July 1996. 

IF (IpreCalc .EQ. 0 .OR. IpreCalc .EQ. 1) THEN 

OrbIncl=51.6 

Apogee=450.0 

Perigee=450 . 0 
ELSEIF (IpreCalc .EQ. 2 .OR. IpreCalc .EQ. 3) THEN 

OrbIncl=28.5 

Apogee=4 50.0 

Perigee=450 . 0 
ENDIF 

C The pre-calculated GTFs are not presently divided into L-bins 

ILbinsum=l 

RETURN 

ENDIF 

C Hardwire shadow to be TRUE 

Shadow= . TRUE . 

C 

C Choose from the two original CREME options for the state of the 

C magnetosphere (quiet or stormy) . Note the stormy option applies on 

C top of the Nymmik correction for mid to high- latitudes . 

C 

9412 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (*,412) 

READ (*, *,ERR=9412, IOSTAT=IERR) Istorm 



Stormy= . FALSE . ^Kt' 
IF (Istorm .EQ^^ Stormy= . TRUE . 




C What is the altitude at apogee? 

C 

9420 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(*,420) 

READ (*,*,ERR=9420, IOSTAT=IERR) Apogee 

C 

C WHAT IS THE ALTITUDE AT PERIGEE? 

C 

9400 CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE(*,400) 

READ (*, *,ERR=9400, IOSTAT=IERR) Perigee 



C allow the user to specify apogee and perigee in either order 

C instead of performing unintended calculation which sets eccentricity 

C to zero and using Perigee variable (actual apogee) to produce 

C a circular orbital altitude in ORBIT routine. 



IF (Perigee .GT. Apogee) THEN 

ApPerSwi t ch=Apogee 

Apogee=Perigee 

Perigee=ApPerSwitch 

WRITE(*,430) 
ENDIF 

E= (Apogee-Perigee) / (Apogee+Perigee+2 . *Re) 
IF (E.LT. .00001) E=0. 

C 

C WHAT IS THE ORBITAL INCLINATION? 

C 

S4 05 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE{*,405) 

READ (*,*,ERR=9405, IOSTAT=IERR) Orblncl 

C Have Removed "FAST" option, i.e. must enter Ascending Node information 
C 

C Retain these initializations in case want to hardwire ascending 

C node information at future time. 

AscNodeLong=0 . 
AscNodeDisp=0 . 
PerigDisp=0 . 

C WHAT IS THE INITIAL LONGITUDE OF THE ASCENDING NODE? 

C 

WRITE(*,409) 



9410 CONTINUE 

CALL RETRY_INPUT (lERR) 
WRITE(*,410) 

READ (*,*,ERR=9410,IOSTAT=IERR) AscNodeLong 

C 

C WHAT IS THE INITIAL DISPLACEMENT FROM THE ASCENDING NODE? 

C 





9415 CONTINUE 

CALL RETRy_INPUf^ERR) 
WRITE(*,415) 

READ (*, *,ERR=9415, IOSTAT=IERR) AscNodeDisp 

IF (E.NE.O.) THEN ! Only read in XI if eccentricity is nonzero 

C 

C What is the displacement of the perigee from the ascending node? 

9425 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(*,425) 

READ (*, *,ERR=9425, IOSTAT=IERR) PerigDisp 
ENDIF 

IF ( (AscNodeLong .NE. 0.0) .OR. (AscNodeDisp .NE. 0.0) .OR. 
& (PerigDisp .NE. 0.0) ) WRITE(*,426) 

Itype = 1 1 hardwire vertical incidence, applied with shadow 

C 

9450 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE{*,450) 

READ {*, *,ERR=9450, IOSTAT=IERR) ILbinMax 
IF (ILbinMax .LT. 0) ILbinMax=0 

IF (ILbinMax .GT. NLvals) THEN 

WRITE (*, 456) 

ILbinMax = NLvals 
ENDIF 

IF ( ILbinMax . GT . 0 ) THEN 
WRITE (*, 451) ILbinMax 

9451 CONTINUE 

CALL RETRY_INPUT{IERR) 

READ (*,*,ERR=9451,IOSTAT=IERR) (XLbounds (L) , L=l , IlbinMax) 
IF (ILbinMax .EQ. 1 .AND. XLBOUNDS(l) .EQ. 0.0) WRITE (*, 458) 
ENDIF 



IF (XLbounds (1) .LT. 0.0) XLbounds ( 1) =0 . 0 

C Start DO loop at 1, so that ILbinMax=2 will be properly handled 

C This SUBROUTINE insists the L- values are in increasing order. 

C If this is not the case, all subsequent L- value bins will be 

C ignored. 



DO L=l, ILbinMax 

I F ( XLbounds ( L ) . LT . XLbounds ( 1 ) ) THEN 
WRITE(*,452) XLbounds (L) ,XLinfinite 
XLbounds (L) =XLinf inite 
ENDIF 

IF (L .GE. 2) THEN 

IF (XLbounds (L) .LE. XLbounds { L ^ 1 ) ) THEN 
WRITE(*,452) XLbounds (L) ,XLinf inite 
XLbounds (L) =XLinf inite 
ENDIF 
ENDIF 
ENDDO 



ILbinsum=l 



DO L=:=l, ILbinMax 

IF ( (L .GE. 2) .AND. (XLbounds (L) .LT. XLinfinite) ) 
& ILbinsum=ILbinsum+l 
ENDDO 

IF (ILbinMax .NE. ILbinsum .AND. ILbinMax .NE. 0) THEN 

WRITE (*, 453) ILbinMax, ILbinsum 

ILbinMax= ILbinsum 
ENDIF 

IF ( ILbinMax .GT. 1 .OR. (ILbinMax .EQ. l .AND. 
& XLBOUNDS (1) .GT. 0.0) ) THEN 

9454 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(*,454) 

READ (*, *,ERR=9454, IOSTAT=IERR) Year 
ENDIF 

9428 CONTINUE 

CALL RETRY_INPUT(IERR) 

IF (ILbinMax .EQ. 0 .OR. (ILbinMax .EQ, 1 .AND. 
& XLBOUNDS (1) .EQ. 0.0) ) THEN 

WRITE(*,427) 

READ ( * , 428 , ERR=9428 , IOSTAT=IERR) GtransFile 
CALL CHECK_OUTPUT_FILE (Gtransf ile, lACCEPT) 
IF (lACCEPT.NE. 0) GOTO 9428 
ELSE 

WRITE ( * , 4 5 5 ) ILbinMax 

READ { * , 428 , ERR=9428 , IOSTAT=IERR) GtransFile 
CALL CHECK_OUTPUT_FILE (Gtransf ile , lACCEPT) 
IF (lACCEPT.NE. 0) GOTO 9428 
DO 1=1, LEN (GtransFile) 

IF (GtransFile (I : I) .EQ. '.') THEN 

GtransFile=GtransFile (1:1-1) 
ENDIF 
ENDDO 
ENDIF 

RETURN 



1000 FORMAT ( IX, 'GEOMAG96 Geomagnetic Transmission Function Model',/) 

1001 FORMAT (' This program will calculate the omnidirectional'. 



& ' geomagnetic transmission' , 

& /, ' function (GTF) to a' , 

& ' spacecraft orbiting inside the magnetosphere . The', 

& /, ' calculated GTF is used by the CREME96', 

& ' particle environment model . ' , 



&//,' NOTE: Before running this or any other CREME96 programs', 
& ' please define three ' , 
& /, ' logicals: ' ,/, 

& /,4x,' CREME96 as the directory where CREME96 source', 

& ' & executables reside.', 

& /,4x,' CR96TABLES as the directory in which CREME96 data', 
& ' tables reside.', 

& /,4x,' USER as the directory in which output files', 

& ' should be written.', 



& //,' Now begin ^^pification of the GTF calculati^^ ' , /) 



C 1 2 3 4 5 

C 12345678901234567890123456789012345678901234567890 

390 FORMAT (IX, 'Enter 1 in order to use a pre-calculated GTF for a' 
& ' typical space shuttle or' , 

& /,3x,' space station orbit, ie., 28.5 deg or 51.6 deg & 450 km 

& //, IX, 'Enter 0 to specify an arbitrary orbit: ', 

& //,3X,'[The pre-calculated GTFs are recommended if appropriate, 

& ' since these use a' 

& /,3x,' better magnetic field model than used in the arbitrary' 

& ' orbit option. ] ' ) 

391 FORMAT (IX, 'Enter 0 for Space Station (51.6 deg., 450 km)', 
& ' orbit (ISSA) , quiet magnetosphere' , 

& /,7X,'l for ISSA, stormy magnetosphere', 

& /,7X,'2 for 28.5 deg. (450 km), quiet magnetosphere', 

& /,7X,'3 for 28.5 deg. (450 km), stormy magnetosphere: ', 

Sc //,3X,'[(a) For solar-quiet periods, the quiet magnetosphere', 

& ' is typical . ' , 

& /,3X,' (b) For solar energetic particles, the stormy ', 

Sc ' 'magnetosphere should also' 

& /,8X,'be considered.]', 

Sc //,3X,'N0TE: the Worst Day in 22 years (see the CREME96', 

St ' environment model) ' 

& /, 3X, ' included a stormy magnetosphere,', 

& ' and thus a stormy option must be considered' , 

& /,3X,'with this Worst Day option.') 

412 FORMAT(/, IX, 'Enter the magnet ospheric field condition: 0 ', 

# 'for quiet; 1 for stormy: 

Sc //,3X, '[(a) For solar-quiet periods, the quiet magnetosphere', 

& ' is typical , ' , 

Sc /,3X,' (b) For solar energetic particles, the stormy ', 

& 'magnetosphere should also' 

Sc /,8X,'be considered.]', 

& //,3X,'N0TE: the Worst Day in 22 years (see the CREME96', 

& ' environment model) ' 

Sc /, 3X, ' included a stormy magnetosphere.', 

& ' For many orbits, the generic stormy GTF' 

Sc /, 3x, ' calculated here', 

Sc ' can be substantially smaller than the actual GTF.') 

420 FORMAT (/, IX, 'Enter altitude at apogee (kilometers): ') 

400 FORMAT (/, IX, 'Enter altitude at perigee (kilometers): ') 

43 0 FORMAT (/, IX, ' Input apogee < perigee, have been interchanged.') 

405 FORMAT (/, IX, 'Enter orbital inclination (degrees): ') 

409 FORMAT (/, IX, 'The remaining input parameters are most relevant', 
Sc ' to situations in which the', 

& /, IX, 'actual orbital path is Icnown' , 

& ' or in which mission critical operations are', 

Sc / , ix, 'planned. ' , 

Sc //,3X,' [Recommended values are 0.0, unless you wish to examine', 

Sc /,3X,'a very specific orbital segment.]') 

410 FORMAT (/, IX, 'Enter initial longitude of ascending node', 
Sc IX, ' [Recommended = 0.0 (degrees)] : ' ) 

415 FORMAT (/, IX, 'Enter initial displacement from ascending'. 



1 ' node'^^P' [Recommended = 0.0 (degreesJ^Hj 

425 FORMAT (/, IX, 'Enter displacement of perigee from^^ 

1 ' ascending node' , IX, ' [Recommended =0.0 (degrees)]:') 

426 FORMAT(/,lX, 'Note: for studies sensitive to a specific, 
& ' orbital segment, you should be', 

& /, IX, 'aware that the GTF' , 

& ' calculations are averaged over 7 days at present. This', 

& /, IX, 'parameter can be easily reset by modifying', 

& ' the GE0MAG96 subroutine, but is ', 

& /,lx,'not provided as a general-use input parameter.') 



a. 



427 FORMAT (/, IX, 'Enter name of output GTF file:', 
& / , ' [Recommended : something . GTF] ' ) 

428 FORMAT {A80) 

450 FORMAT (/, IX, 'Enter the number of desired GTF L-value bins ' 
& ' (1 - 10) : ' , 

& /, 3X, ' [Recommended default = 0, i.e. ', 

& 'one GTF for the entire orbit.]') 

451 FORMAT (/, IX, 

& 'Enter the lower limits of the ',12,' L-value bins: ', 

& /,3X,' [A typical scenario could be to request 4 bins as the', 

& 'as the previous entry.', 

& /,3X,'Then, entries of 0.0, 2.0, 4.0, and 6.0', 

St ' would subdivide the orbit into', 

Sc /,3x, 'sections with L < 2, L = 2-4, L = 4-6, and L > 6.]', 

& //,1X,'N0TE: The L-value is a magnetic coordinate roughly', 

Sc ' corresponding to the ' , 

& /, IX, 'distance in Earth Radii to the', 

Sc ' magnetic field line at the magnetic equator.', 

& /,lx,'For example, a geosynchronous orbit is roughly L = 6.6,', 

& ' the geographic equator' , 

Sl /,lx,'is about L = l, and the heart of the', 

Sc ' South Atlantic Anomaly (SAA) is roughly at', 

& /,lx, 'L = 1.2 - 2. ' , 

& ' Calculated L-values slightly less than 1 do occur; using' , 

& /,lX,'a lower limit of L = 0 will account for these.') 

452 FORMAT (IX, 'The L-values MUST be entered in increasing order', 
& /,lX,'the L-value of ',F10.2,' has been reset to ',F10.2) 

453 FORMAT (IX, 'The number of L-values bins has been reset', 
& /,1X, ' from ' ,12, ' to ' ,12) 

454 FORMAT (/, IX, 

Sc 'Enter the decimal year for the field model in the ', 

& 'L-value calculations:', 

& /,1X,' [Since the present IGRF grid calculations were performed', 

& ' for 1980.0, that date', 

& /,1X,'' is presently recommended for consistency.]') 

455 FORMAT (/, IX, 'Enter root name of output GTF files:', 

& /, IX, '[NOTE: There will be ',12,' output files, and', 

& ' the files for the different L-value' 

& /,lx,' bins will', 

& ' be called something . GT# (# = 1, 2 , . . . , 9, X) ] ' ) 



456 FORMATdX.'Onl^L -values are allowed.') 



458 FORMAT (IX, 'Calculation reset to whole orbit option, since', 
& IX, 'choosing 1 L bin', 

& /,1X,' with a minimum L-value equal to 0 is equivalent to', 

& IX, 'the entire orbit.') 

END IGTFDriverlnput routine 



SUBROUTINE HEA^ 
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In_upsets (LET_FILE, XM, YM, ZM, ] 
IPARAM,PARAMS, 
XSECT_FILE , NBITS , lENTER , 
SEU^RATE , DAY_RATE , PERSECOND , PERDAY) 



Subroutine for performing heavy- ion evaluation: 



Inputs: LET FILE 



Outputs : 



file containing integral LET spectrum 

(in ions/m2-s-sr) vs. LET (in MeV-cm2/g) 
XM,YM,ZM = bit dimensions (in microns) 

FUNNELM = funnel length (optional; default 0) in microns 
IPARAM = 1,2,4, indicating cross-section model 

1 = Bendel 1 -parameter 

2 = Bendel 2 -parameter 

4 = Weibull 

5 = Critical charge (pc) 
0 = table 

PARAMS(4) = array containing cross-section parameters 

XSECT_FILE = file containing cross-section table. 
NBITS = no. bits in the device: 

SEU_RATE in SEUs/bit/second 

DAY^RATE in SEUs/bit/day 

PERSECOND in SEUs/device/second 

PERDAY in SEUs /device/day 



Written by: Allan J. Tylka . 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka@crs2 . nrl . navy . mil 



IMPLICIT NONE 

INTEGER*4 NB INS , NPTS , I PARAM , K , IENTER,MPTS 

REAL* 4 LET , LETMG , FLUX , PARAMS , XM , YM , ZM , FUNNELM , XSECT , QC 

REAL*4 NBITS, SEU_RATE 

REAL*4 DAY_RATE, PERSECOND, PERDAY 

CHARACTER* 8 0 LET_FILE , XSECT_FILE 

PARAMETER (NBINS=5000) 

DIMENSION LET(NBINS) , LETMG (NBINS) ,FLUX(NBINS) , XSECT (NBINS ) 
DIMENSION PARAMS (4) 



9998 



WRITE (6, 9998) 

FORMATdx,' HI_UPSET_DRIVER calculation started.'. 
Please stand by.') 

SEU_RATE=0.0 

On first entry, get integral LET spectrum: 
IF (lENTER.EQ.l) THEN 

CALL UNLOAD_LET_SPECTRUM ( LEt_FILE , LET , FLUX , NPTS ) 



LET in spectrui^Ple is in MeV-cm2/g; but cross^ption evaluation 
expects it in Me^cm2/mg. 



DO 100 K=1,NPTS 

LETMG (K) =LET (K) *0 . 001 
CONTINUE 

ENDIF 



IF (XM*YM.GT.O.O) THEN 
IF (IPARAM.NE. 5) THEN 

For devices in which the cross -section has not reached its 
limiting value at effective LET ^ LET(NPTS), the cross-secti 
table must be extended to higher effective LETs to MPTS : 

CALL EXTEND_EFFECTIVE_LET_RANGE (NPTS , NBINS , 

XM , YM , ZM , FUNNELM , MPTS , 
LET, LETMG, FLUX) 

Evaluate SEU cross-section at these effective LET values: 

CALL EVALUATE_SEU_CROSS_SECTION(LETMG,MPTS, IPARAM, PARAMS, 

XSECT_FILE,XSECT) 

Calculate SEU rate: 

CALL INTEGRATE_HEAVY_ION_UPSETS (MPTS , LET , FLUX , XSECT , 

XM, YM, ZM, FUNNELM, 
SEU_RATE) 



ELSEIF (IPARAM.EQ.5) THEN 
QC=PARAMS (1) 

CALL GET_UPSET (XM, YM, ZM, FUNNELM, QC, NPTS , LET, FLUX, SEU_RATE) 
Re-scale to allow for possibility of different limiting 
cross-section, rather than the customarily used XM*YM 
SEU_RATE=SEU_RATE*PARAMS (2) /XM/YM 

• ENDIF 
ENDIF 

I F ( SEU_RATE . LT . 0 . ) THEN 
WRITE (6, 999) SEU_RATE 

FORMAT dx,' ERROR in HEAVY_ION_UPSETS : SEU RATE = ',E13 5) 
SEU_RATE=0 .0 
ENDIF 



CALL CALC_SEU_RATE (NBITS , SEU_RATE , DAY_RATE , PERSECOND , PERDAY) 
WRITE(6,9999) 

FORMAT dx,' HI_UPSET_DRIVER calculation completed. ') 



RETURN 
END 



C 
C 
C 



SUBROUTINE EXTEND_EFFECTIVE_LET_RANGE (NPTS , NBINS , 
& XM,yM,ZM,FUNNELM,MPTS, 
^ LET, LETMG, FLUX) 

Based on device dimesions, extends the range of effective LET 
values from NPTS to MPTS 

IMPLICIT NONE 

INTEGER* 4 NPTS , NBINS , MPTS 

REAL*4 XM, YM, 2M,FUNNELM 

REAL*4 LET, LETMG, FLUX 

DIMENSION LET (1) , LETMG (1) , FLUX (1) 

INTEGER* 4 K, NLAST, NEXTRA 

REAL*4 FACTOR, DL 

MPTS=NPTS 



m 
yJ 



C Locate last non-zero integral flux point: 

NIiAST=0 

DO 100 K=1,NPTS 

IF (FLUX(K) .LE.0.0 .and. NLAST. EQ.O) NLAST=K 
100 CONTINUE . 

FACTOR= (SQRT {XM*XM+YM*YM+ZM*ZM) +FUNNELM) /ZM 

DL= ALOG ( LET ( NPTS ) /LET { 1 ) ) * * ( 1 . / FLOAT (NPTS - 1 ) ) 

NEXTRA=1 . +ALOG (FACTOR) /ALOG (DL) 

MPTS=NEXTRA+NLAST 

IF (MPTS .GT. NBINS) MPTS=NBINS 

IF ( MPTS. GT. NPTS) THEN 

DO 200 K=NPTS+1,MPTS 

LET(K) =LET(NPTS) *DL** (K-NPTS) 

LETMG (K) =LET (K) *0 . 001 

FLUX(K) =0.0 
200 CONTINUE 
ENDIF 



C 
C 
C 
C 
C 
C 



Debug : 
TYPE *, 
TYPE *, 
TYPE *, 
TYPE *. 



NPTS, LET (NPTS) : 
NLAST, LET (NLAST) : 
FACTOR , NEXTRA, MPTS ; 
LET (MPTS) : 



,NPTS, LET (NPTS) 
, NLAST, LET (NLAST) 
' , FACTOR, NEXTRA, MPTS 
' , LET (MPTS) 



RETURN 
END 



PROGRAM HI_UPSE 
IMPLICIT NONE 

REAL*4 XM, YM,ZM,FUNNELM,NBITS,PARAMS 
REAL* 4 XMO,YMO,ZMO 

REAL* 4 SEU_RATE , DAY_RATE , PERSECOND , PERDAY 
INTEGER*4 IPARAM, IREPEAT, lENTER 
DIMENSION PARAMS(4) 

CHARACTER*80 LET_FILE , XSECT_FILE, REPORT_FILE 

CHARACTER* 40 DEVICE_LABEL 

INTEGER*4 lERR 

DATA IERR/0/ 

INTEGER*4 lENT 

DATA IENT/0/ 

C 

C Modified 11/8/96: to extract XM,YM from cross-section data 

C if user supplies XM=yM=0. 

C 

IENTER=1 
10 CONTINUE 

CALL INITIALIZE_HI_UPSETS (LET_FILE , XMO , YMO , ZMO , FUNNELM, NBITS , 
& IPARAM, PARAMS, XSECT_FILE, lENTER, 

& DEVICE_LABEL, REPORT_FILE) 

CALL CHECK_RPP_DIMENSIONS (XMO , YMO , ZMO , 
& IPARAM, PARAMS , XSECT_FILE , 

& XM,YM,ZM) 



CALL HEAVY_ION_UPSETS {LET_FILE , XM, YM, ZM, FUNNELM, IPARAM, PARAMS, 
& XSECT_FILE , NBITS , lENTER , 

& SEU_RATE , DAY_RATE , PERSECOND , PERDAY) 

CALL HI_UPSET_REPORT(LET_FILE,XM,YM, ZM, FUNNELM, NBITS , 
& IPARAM, PARAMS, XSECT_FILE, lENTER, 

& DEVICE_LABEL,REPORT_FILE, 
& SEU_RATE , DAY_RATE , PERSECOND , PERDAY) 



CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9200) 

FORMAT(//,' Repeat SEU rate calculation with different', 

' device characteristics? (l=yes, 0=no) ' ) 
READ(*, *,ERR=9100, IOSTAT=IERR) IREPEAT 
IF (I REPEAT . EQ . 1 ) THEN 
IENTER=IENTER+1 
GOTO 10 
ENDIF 

WRITE (6, 9600) 

9600 FORMATdx,' Heavy Ion Upset Calculations finished.') 
STOP 
END 



9100 
9200 



SUBROUTINE HI_U:i^P|_REPORT (LET_FILE , XM, YM, ZM, FUnIJ^NBITS , 

& IPARAM,PARAMS,XSECT_FILE, lENTER, 

& DEVICE_LABEL , REPORT_FILE , 

& SEU_RATE , DAY_RATE , PERSECOND , PERDAY) 



IMPLICIT NONE 

REAL*4 XM, YM, ZM,FTOJNEL,NBITS, PARAMS 
REAL* 4 SEU_RATE , DAY_RATE , PERSECOND , PERDAY 

INTEGER*4 IPARAM, lENTER, OUTUNIT, VERSION_NUMBER, NHEADERO , K 
INTEGER*4 NHEADER , PROGRAM_CODE , STAT , CREME96_OPEN 
DATA OUTUNIT/2/ 
DIMENSION PARAMS(4) 

CHARACTER* 8 0 LET_FILE , XSECT_FILE , REPORT_FILE 
CHARACTER* 40 DEVICE_LABEL 
CHARACTER* 9 CREATION_DATE 
CHARACTER* 8 CREATION_TIME 

PROGRAM_CODE= 1 0 

IF (IENTER.EQ.l.and.REPORT_FILE.NE. 'NULLFILE' ) THEN 
C OPEN (UNIT=OUTUNIT, FILE= ' USER : ' //REPORT_FILE, STATUS= ' NEW ) 

Stat = creme96_open{report_f ile, 'user' ,outunit, 'new' ) 
CALL DATE(CREATION_DATE) 
y CALL TIME(CREATION_TIME) 

CALL GET_CREME96_VERSION(VERSION_NUMBER) 
y CALL; CHECK_HEADER_LENGTH ( LET_FILE , NHEADERO ) 

C3 NHEADER=NHEADER0+2 

[U WRITE (OUTUNIT, 991) NHEADER, REPORT_FILE (1 : 70) , 

D & VERS ION_NUMBER , PROGRAM_CODE 

y 991 F0RMAT(I3, lx,A70, 14, 12) 

H= WRITE (OUTUNIT, 992) VERS ION_NUMBER , GREAT I ON_DATE , CREATION_TIME 

s 992 FORMAT (Ix, '%Created by CREME96:HI_UPSET_DRIVr:R Version ',14, 

M & ' on ' ,A9, ' at ' ,A8) 

fU 

y C Now copy header information from input file: 

U WRITE (OUTUNIT, 993) LET_FILE (1 : 40) 

]^ 993 FORMAT ( Ix, '% Input Integral LET Spectrum File: ' ,A40) 
=.^1 CALL COPY_HEADERS (LET_FILE, NHEADERO, OUTUNIT) * 

ENDIF 

IF (REPORT_FILE . NE . ' NULLFILE ' ) THEN 
WRITE (OUTUNIT, 994) lENTER, DEVICE_LABEL 

994 FORMAT(/,Xx, ' REPORT NO. ',14,': ',2x,A40) 
WRITE (outunit , 995) XM, YM, ZM, FUNNEL 

995 FORMAT (Ix,' RPP Dimensions: X = ',F10.5,' Y = ',F10.5, 
& ' Z = ',F10.5,' microns.', 

& /,lx, ' Funnel lengths ',F10.5,' microns.') 

IF (IPARAM. EQ.O) WRITE (outunit , 980 ) IPARAM, XSECT_FILE (1 : 75) 
IF (IPARAM. EQ.l) WRITE (outunit , 981 ) IPARAM, PARAMS (1) 
IF (IPARAM. EQ. 2) WRITE (outunit , 982 ) IPARAM, PARAMS (1) , PARAMS (2) 
IF (IPARAM. EQ. 4) WRITE (outunit , 984 ) IPARAM, (PARAMS (K) , K=l , 4 ) 
IF (IPARAM. EQ. 5) WRITE (outunit , 985 ) IPARAM, PARAMS ( 1) , PARAMS (2 ) 
WRITE (outunit, 996) NBITS 

996 FORMAT (Ix,' Number of bits = ',E13.5) 

980 FORMAT (Ix, ' CROSS-SECTION INPUT ' , 13, ' FROM FILE: ' , 
& /,5x,A75) 

981 FORMAT (Ix,' CROSS-SECTION INPUT ',13, 

& ' BENDEL 1-PARAMETER = ',E13.5) 



982 



984 



985 



& 

Sc 

& 
& 

& 



FORMAT (Ix,' CRi 



FORMAT (Ix, 

/,5x, 
/,5x, 
/,5x, 
/,5x, 
FORMAT (Ix, 
/,5X, 
/,5x, 




' ,2E13.5) 



ECTION INPUT ' , 13, 
BEIWEL 2 -PARAMETERS A,B = 
CROSS-SECTION INPUT ',13, 

WEIBULL FIT: ' , 
ONSET = ',F9.3,' MeV-cm2/milligram' , 
WIDTH = ' , F9 . 3 , ' MeV-cm2 /milligram' , 
POWER = ',F9.3,' (dimensionless) ' , 
PLATEAU = ',F9.3,' square microns/bit') 
CROSS-SECTION INPUT ',13, 

Critical charge - ',E13.5,' picocoloumbs ' , 
Cross-Section = ', E13 . 5, '. square microns/bit ' ) 



WRITE (outunit, 9200) 

WRITE (outunit , 9201) I ENTER, SEU__RATE, DAY_RATE, PERSE COND, PERDAY 

9200 FORMAT (2x, 'Rates: SEUs/bit/second /bit/day', 
& ' /device/second /device/day' ) 

9201 F0RMAT(2x, '***★*' , 14 , 2x, 4 {E14 . 5 , 2x) ) 
ENDIF 

WRITE(6, 9200) 

WRITE (6 , 9201) lENTER, SEU_RATE, DAY_RATE, PERSECOND, PERDAY 



RETURN 
END 



SUBROUTINE indexxi^^lMAX, arr , indx) 
IMPLICIT NONE 
C Explicit variable lengths added AJT 12-12-96 

C INTEGER n , indx ( n ) , M , NSTACK 

C REAL arr(n) 

C PARAMETER (M=7 , NSTACK=50 ) 

C INTEGER i , indxt , ir , itemp , j , j stack , k, 1 , istack (NSTACK) 

C REAL a 

C Parameter NMAX added to define size of passed-in arrays. 

INTEGER*4 n, NMAX, indx (1) , M, NSTACK 
REAL*4 arr(l) 
PARAMETER ( M= 7 , NSTACK= 5 0 ) 

INTEGER*4 i, indxt , ir, itemp, j , j stack, k, 1, istack (NSTACK) 
REAL* 4 a 

IF (N.GT.NMAX) THEN 

WRITE(6,9999) N,NMAX 
9999 FORMATCS 99999 ABNORMAL TERMINATION: 

& /,lx,' Error in INDEXX: N,NMAX: ',2112, 

& /,lx,' STOP.') 

STOP 
endif 

do 11 j=l,n 
indx(j) =j 
P=i 11 continue 
^* jstack=0 

S 1=1 

^ ir=n 

y 1 if {ir-l.lt.M)then 

do 13 j=l+l,ir 
'ri indxt=indx( j ) 

a=arr (indxt) 
N= do 12 i=j-l,l,-l 

f if (arr (indx(i) ) .le.a)goto 2 

indx{i+l) =indx (i) 
rU 12 continue 
W i=0 
1=^ 2 indx (i+1) =:indxt 

=iQ 13 continue 
sA if { jstack.eq. 0) return 

ir=istack ( jstack) 

l=istack (j stack- 1) 

jstack= jstack-2 
else 

k=(l+ir) /2 

itemp=indx(k) 

indx (k) =indx (1+1) 

indx (1+1) =itemp 

if (arr (indx (1+1) ) .gt . arr (indx (ir) ) ) then 

itemp=indx (1+1) 

indx (1+1) =indx (ir) 

indx (ir) =i temp 
endif 

if (arr (indx (1) ) .gt . arr (indx (ir) ) ) then 

itemp=indx (1) 

indx (1) =indx (ir) 

indx (ir) =itemp 
endif 

if (arr (indxd + l) ) .gt .arr (indx (1) ) ) then 
itemp=indx (1+1) 
indx(l+l)=indx{l) 





indx(l)=iter^^ 

endif 
i=l+l 
j = ir 

indxt=indx(l) 
a=arr (indxt) 
continue 

if (arr{indx{i) ) .It .a)goto 3 
continue 
j=j-l 

if (arr{indx(j) ) .gt.a)goto 4 

if (j .lt.i)goto 5 

itemp=indx(i) 

indx{i) =indx{j) 

indx(j)=itemp 

goto 3 

indx{l)=indx{j) 
indx(j) =indxt 
jstack=jstack+2 

if (j stack. gt.NSTACK) pause 'NSTACK too small in indexx' 
if ( ir- i+1 . ge . j - 1 ) then 

istack (j stack) =ir 

istack( j stack- 1) =i 

ir=j -1 
else 

istack (jstack) =j -1 
istack{ jstack-1) =1 
l=i 



endif 



endif 
goto 1 
END 



SUBROUTINE INIFL^^ZMIN, IZMAX, EMIN, EMAX, YEAR, IMC^^TRANS, 

GTRANSFILE, TRAPDFILE, FLXFILE) 



C 



C Subroutine for initializing input parameters to CREME96 environment 

C model . ^ 

C 

C Modified 9/12/96: Energy range fixed at O.l-l.OE+5 MeV/nuc; 

C However, the external flux routines return 0 for 

C E < 1.0 MeV/nuc; the 0.1 threshold is put in here 

C for subsequent tracking through shielding. 

C 

C 

C Modified 11/18/97: Allow input of trapped proton file. 



C 
C 

IMPLICIT NONE 

INTEGER*4 IMINTEMP, IMAXTEMP, lACCEPT, IFILETYPE 

INTEGER*4 IZMIN, IZMAX, IMODE, ITRANS , ITYPE , ITRP 

INTEGER*4 ISEPMODE 

REAL.*4 EMIN,EMAX, YEAR,YEARDUM 

REAL* 4 EMINTEMP,EMAXTEMP 

CHARACTER*80 GTRANSFILE, TRAPDFILE, FLXFILE 
CHARACTER*! IBLANK 
DATA IBLANK/' '/ 
INTEGER*4 lERR 
DATA IERR/0/ 

C 



WRITE (6, 1000) 

1000 FORMAT (' CREME96 IONIZING RADIATION ENVIRONMENT MODEL',/, 
& ' > FLUX_DRIVER Module: External Environment') 

WRITE (6, 1001) 

1001 FORMAT ( 

& ' This program will calculate the particle environment' , 
& ' outside of the spacecraft.',/, 

& ' You must run additional programs after this to' , 
& ' (1) transport the particles' 

& /,' through shielding; and (2) calculate SEU rates.', 
&//,' BEFORE RUNNING THIS OR ANY OTHER CREME96 PROGRAM', 
& ' PLEASE DEFINE THREE LOGICALS : ' , / , 

& /,4x,' CREME96 as the directory where CREME96 source', 

& ' & executables reside . ' , 

& /,4x,' CR96TABLES as the directory in which CREME96 data', 
fic ' tables reside.', 

& /,4x,' USER as the directory in which output files', 

& ' should be written. ' , 

& //i' Now begin specification of the environment parameters: ') 

101 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6,1002) 

1002 FORMAT (/,' Enter minimum & maximum atomic numbers: ', 
& /, ' Recommended for most applications: 

& ' IZMIN = 1 (hydrogen) to IZMAX = 28 (nickel).', 

& / , ' [Enter 0 0 <CARRIAGE RETURN> for recommended values . ] ' 

& /,' NOTE: For >95% of all SEU applications, Z > 28', 

& ' elements, which are very' , 

& /,' rare, may be neglected. However, for SEU rates in', 
& ' devices with high' , 



& thresl^^ (> 15 MeV-cm2/mg) these hea^B elements', 

& ' MAY be impSrtcUit , ' , 

fic particularly for low- inclination low-Earth orbits', 

& ' or for applications', 

& demanding very low SEU rates. Please note that', 

& ' including Z > 28 elements in' , 

/ , ' you calculations can' , 
& ' significantly slow down some parts of the CREME96 code ' ) 

READ(*,*,ERR=101, IOSTAT=IERR) IMINTEMP, IMAXTEMP 
IZMAX=MAX (IMINTEMP, IMAXTEMP) 
I ZMIN=MIN( IMINTEMP, IMAXTEMP) 
IF (IZMIN.EQ.O .and. IZMAX.EQ.O) THEN 
IZMIN=1 
IZMAX=28 
ENDIF 



IF (I2MIN.LE.0 .or. IZMAX.GT.92) THEN 
WRITE (6, 9001) IZMIN, IZMAX 

9001 FORMATdx,' Invalid atomic number (s ) : ',215, 
& //Ix,' Please try again.') 

GOTO 101 
ENDIF 

WRITE (6, 9002) IZMIN, IZMAX 

9002 FORMATdx,' Lowest atomic number = ',15, 
& /,lx,' Highest atomic number = ',15) 

103 CONTINUE 
EMIN=0 . 1 
EMAX=1.0E+5 

C 

C Following code for specifying energy interval obsolete 9/12/96- 

C CALL RETRY_INPUT{IERR) 

C WRITE(6,1003) 

C 1003 FORMAT(/,' Enter minimum & maximum energy (in MeV/nuc) : ', 

^ ^ //' Recommended for most SEE applications: ', 

^ ^ ' EMIN = 10.0; EMAX = l.OE + 5') 

C TYPE *,' [Enter 0 0 <CARRIAGE RETURN> for recommended values ] 

C READ(*,*,ERR=103,IOSTAT=IERR) EMINTEMP, EMAXTEM? 

C EMIN=MIN { EMINTEMP , EMAXTEMP ) 

C EMAX=MAX ( EMINTEMP , EMAXTEMP ) 

C IF (EMAX. LE. 0.0 .and. EMIN. LE. 0.0) THEN 

C ENDIF 

C IF (EMIN.LE.O .or. EMAX. LE. 0.0 .or. EMIN. EQ . EMAX) THEN 

C TYPE *,' Invalid energy value(s): ', EMIN, EMAX 

C TYPE *,' Please try again.' 

C GOTO 103 

C ENDIF 

C TYPE ♦,' Minimum energy = ',EMIN, ' MeV/nuc ' 

C TYPE *,' Maximum energy = ',EMAX,' MeV/nuc ' 



C 



104 CONTINUE 

CALL RETRY_INPUT (lERR) 
. WRITE (6, 1004) 
1004 FORMAT(/,' Specify type of environment model: ', 
& ' Enter 0 or 1 : ' , 

& /,| 0 = Solar-quiet (ie., no Solar Energetic Particles) 
fi^ /, ' 1 = Solar Energetic Particles ONLY' ) 



WRITE(6, 1041) 

1041 FORMAT (' NOT^^hoosing 1 (Solar Energetic Particles ONLY) 
& ' does not include', 

& Galactic cosmic rays, which may also contribute', 

& ' to the SEU rate behind', 

& /,' thick shielding during a solar particle event.') 

READ(*, *,ERR=104, IOSTAT=IERR) ITYPE 



IF (ITYPE. NE.O .and. ITYPE. NE.l) THEN 
WRITE(6, 9010) ITYPE 

FORMAT (Ix, ' Environment type ' , 16, ' unknown. ' , 

/,lx,' Please try again.') 
GOTO 104 
ENDIF 



GTRANSFILE=:' 
TRAPDFILE =' 



105 CONTINUE 

CALL RETRY_INPUT{IERR) 
IF ( ITYPE. EQ.O) THEN 
IMODE=0 
V7RITE(6, 1005) 

1005 FORMAT(/,' Solar-quiet period. Enter decimal year', 
& ' (eg. 1996.42) OR ' , 

& /,3x,'0 for Solar Minimum (Cosmic-Ray Maximum, YEAR =1977.0) 
& /,3x,'l For Solar Maximum (Cosmic-Ray Minimum, YEAR =1990.2) 

READ (* , * , ERR=105 , IOSTAT=IERR) YEARDUM 

IF (ABS (YEARDUM) . LE . 0.0001) THEN 

YEAR=1977.0 
WRITE (6, 9020) YEAR 

9020 FORMATdx,' Solar Minimum (Cosmic -Ray Maximum) YEAR = ',F10.3) 
ELSEIF (ABS (YEARDUM- 1.0) .LE. 0.0001) THEN 

YEAR=1990.2 

WRITE (6, 9021) YEAR 

9021 FORMATdx,' Solar Maximum (Cosmic -Ray Minimum) YEAR = ' FIO 3) 
ELSE 

YEAR=YEARDUM 
WRITE (6, 9022) YEAR 

9022 FORMATdx,' YEAR = ',F10.3) 
ENDIF 



ELSEIF ( ITYPE. EQ.l) THEN 



YEAR=0.0 



106 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE{6, 1006) 

1006 FORMAT(/,' CREME96 currently provides three Solar Energetic, 
& ' Particle Models: ', 

& /,3x,' Worst Week in 22 years: based on observed proton and' 

& ' heavy- ion fluences', 

& /,28x,' on 19-26 October 1989;', 

& /,3x,' Worst Day in 22 years: based on observed proton and' 
& ' heavy- ion fluences', 

& /,28x,' on 20 October 1989', 



& /,3x,' Peak ^•antaneous Flux: based on peaMpiinute- ' 

& 'averag^n.uxes observed', ^ 

& /,28x,' during 19-26 October 1989.', 
& /,3x,' Enter 1 for worst week; 2 for worst day;', 
& ' 3 for peak flux: ') 

READ(*, *,ERR=106, IOSTAT=IERR) ISEPMODE 

C 

C Sloppy coding, introduced here on 9/14/96: ISEPMODE gives 

C natural progression toward increasing severity, which is 

C incompatible with original definitions of IMODE. Unfortunate 

C the IMODE values are deeply imbedded in the code and I have 

C chosen not to change them at this time. 

C 

IF ( ISEPMODE. EQ. 2) THEN 
IM0DE=1 
WRITE (6, 1007) 

1007 FORMAT (' Worst Day Solar Energetic Particle Model chosen. 
ELSEIF (ISEPMODE. EQ.l) THEN 

IMODE =2 
WRITE (6, 1008) 

1008 FORMATC Worst Week Solar Energetic Particle Model chosen 
ELSEIF ( ISEPMODE. EQ. 3) THEN 

IMODE=3 
WRITE (6, 1081) 

1081 FORMATC Peak Solar Energetic Particle Flux Model chosen 

ELSE 

WRITE (6, 1009) 

1009 FORMATC Requested SEP environment not defined.', 
& ' Please try again.') 

GOTO 106 
ENDIF 

ENDIF 

107 CONTINUE 

CALL RETRy_INPUT{IERR) 
WRITE (6, 1010) 

1010 FORMAT{/,' Specify Environment Location: ', 
& ' Enter 0 or 1 : ' , 

& /, ' 0 = Interplanetary Space near Earth' , 

^ (ie., outside of Earths magnetosphere) ' 

& /, ' 1 = Inside Earths magnetosphere' , 

& /,' (You will need to supply a geomagnetic transmission', 

& ' function file.', 

& / , ' Run GTRANS_DRIVER to make one . ) ' ) 

READ ( * , * , ERR=107 , IOSTAT=IERR) ITRANS 

IF (ITRANS. NE.O .and. ITRANS. NE.l) THEN 
WRITE (6, 9030) ITRANS 
9030 FORMATdx,' Environment location ',15,' unknown.', 

& ' Please try again.') 

GOTO 107 
ENDIF 

IF ( ITRANS. EQ.O) THEN 
WRITE(6, 1011) 
1011 FORMATC Geosynchronous Orbit or' 

& ' Near-Earth Interplanetary Space') 

ELSEIF (ITRANS. EQ.l) THEN 
112 CONTINUE 



_^Vr(IERR) 



CALL RETRY_ 
WRITE(6, 10l51 

1012 FORMAT {' Inside Earths Magnetosphere') 
WRITE (6, 1013) 

1013 FORMAT (' Specify name of geomagnetic transmission file: 
& /,' ie., some thing. GTF ' ) 

READ (*, 1014, ERR=112, IOSTAT=IERR) GTRANSFILE 

1014 FORMAT (A80) 

IF (GTRANSFILE. EQ. IBLANK) THEN 
WRITE (6, 1914) 

1914 FORMAT dx,' You must specify a geomagnetic transmission', 

& ' file (.GTF) for the calculation you', 

& /,lx, ' have outlined. Please try again.',/) 

GOTO 112 
ELSE 
IFILETYPE=2 

WRITE (6, 1015) GTRANSFILE 

1015 FORMAT (' Geomagnetic Transmission File =',/,lx,A80) 
CALL CHECK_FILE (IFILETYPE, GTRANSFILE, lACCEPT) 

IF ( I ACCEPT. NE.O) GOTO 112 
ENDIF 

ITRP=0 

Q IF (IZMIN.EQ.l) THEN 

® IF (IMODE.EQ.O) THEN 

□ 116 CONTINUE 

Q CALL RETRY_INPUT{IERR) 

fU WRITE(6, 1016) 

P 1016 FORMATC Include Trapped Protons? (0=no; l=yes) ' ) 



C 

C WRITE (6, 9999) 

C 9999 FORMATdx,' *** NOTE: This test version of CREME96' 

^ ^ ' does NOT include trapped protons . ' , 

C & /,lx,' Please enter 0') 

C 

READ(*,*,ERR=116,I0STAT=IERR) ITRP 
ENDIF 



I y 

hi 



IF (ITRP.EQ.O) THEN 
WRITE(6, 1027) 

^027 FORMATdx,' No Trapped Protons Included.') 

ELSEIF (ITRP.EQ.l) THEN 
117 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1017) 
1017 FORMATC Trapped Protons included.', 

& /,lx,' Enter name of, 

& ' file containing orbit -averaged trapped proton flux:') 

READ (* , 1014 , ERR=117 , IOSTAT=IERR) TRAPDFILE 



IF ( TRAPDFILE. EQ.IBLT^) THEN 
WRITE (6, 1917) 

FORMATdx,' You must specify a trapped proton', 
file for the calculation you have outlined.', 
/, Ix, ' Please try again. ' , /) 
GOTO 117 
ELSE 



rET6,1018) TRAPDFILE 



IFIU 
WRITE! 

1018 FORMATC Trapped Proton Flux File =',/,lx,A80) 
CALL CHECK_FILE (IFILETYPE, TRAPDFILE, lACCEPT) 
IF { IACCEPT . NE . 0 ) GOTO 117 

ITRANS=2 
ENDIF 

ENDIF 
ENDIF 
ENDIF 

119 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6,1019) 

1019 FORMAT(/,' Particle environment specification now completed. 
Sc /,' Enter name of output file: ' 

& /, ' Note: for standard CREME96 format, must be', 

& ' something. FLX' ) 

120 CONTINUE 

READ (*, 1014, ERR=119, IOSTAT=IERR) FLXFILE 
WRITE (6 , 1020) FLXFILE 

1020 FORMATC Output FLxix File =',/,lx,A80) 

CALL CHECK_OUTPUT_FILE (FLXFILE, lACCEPT) 
IF ( lACCEPT. NE.O) GOTO 120 



RETURN 
END 



FILE , LETMINMG , LETMAXMG , 



SUBROUTINE INIDO|^ 

IZMIN, IZMAX, EMINCUT, EMAXCUT, MATERIAL, OUTF I LE) 

: Subroutine for initializing input parameters to the DOSE program 

: in CREME96. This version only allows SILICON devices. 

IMPLICIT NONE 

INTEGER*4 IZMIN, IZMAX, IMINTEMP, IMAXTEMP, IFILETYPE, lACCEPT 
REAL* 4 LETMINMG, LETMAXMG, LETMINTEMP, LETMAXTEMP 
' REAL*4 EMINCUT, EMAXCUT 
CHARACTER* 80 INFILE, OUTFILE , DEFAULT_NAME 
CHARACTER*12 MATERIAL 
CHARACTER*! IBLANK 
DATA IBLANK/' '/ 
INTEGER*4 lERR, IDIFSPEC, ILONG 
DATA IERR/0/ 

WRITE (6, 1000) 

1000 FORMAT (' CREME96 IONIZING RADIATION ENVIRONMENT MODEL', 
& /,' --> Ionizing Dose Calculation') 

WRITE (6, 1001) 

1001 FORMAT (' This program will calculate the dose resulting from', 
& ' CREME96 differential', 

& /,' particle fluxes. This program is intended primarily for', 
& ' calculating dose due to' , 

& /,' NON-TRAPPED components of the radiation environment', 
& ' [cosmic rays and solar' , /, ' energetic' , 
& ' (flare) particles] . ' , 

Sc ' This program is NOT recommended for calculating' , 

& /,' dose due to TRAPPED particles,', 

& . ' which generally dominate the dose inside', 

& / , ' Earths magnetosphere . ' , 

Sc ' CREME96 does NOT included trapped electrons, and', 

& /,' trapped-proton dose is more accurately described', 

& ' by other programs, especially', 

& for lightly- shielded systems.', 

&//, ' Before running this program, you must do:', 

&//,' FLUX', 

& ' to generate the particle environment outside' , 
& ' the spacecraft; and', 
& / , ' TRANS ' , 

& ' to transport fluxes through the spacecraft shielding.'. 
El//,' NOTE: Before running this or any other CREME96 program', 
& ' please define 3 logicals : ' , / , 

& /,4x,' CREME96 as the directory where CREME96 source', 

& ' & executables reside.', 

& /,4x,' CR96TABLES as the directory in which CREME96 data', 
& ' tables reside.', 

& /,4x,' USER as the directory in which output files', 

& ' should be written.', 

& //,' Now begin specification of the DOSE_DRIVER inputs: ') 
INFILE= ' 



112 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1002) 
1002 FORMATC Enter name of file containing', 
& ' CREME96 particle fluxes: ' 

& /,' ie. something . TFX from TRANS or'. 



(^||zero shielding) something . FL^^Hbn 
DmShing.TR* from TRP:') 



^ (^■■zero shielding) something . FLi^^bm FLUX' 

& , ' or somShing.TR* from TRP:') 

READ 1014, ERR=112, IOSTAT=IERR) INFILE 
1014 FORMAT (A80) 

IF (INFILE. EQ.IBLANK) THEN 
WRITE (6, 1914) 

1914 FORMATdx,' You must specify an input file here,', 

& ' either from TRANS or' , 

& /,lx,' (in the case of zero shielding) from', 
& ' FLUX or TRP . ' , 

& ' Please try again.',/) 

GOTO 112 

ELSE 

IFILETYPE=4 
WRITE (6, 1020) INFILE 
1020 F0R^4AT(' Input Flux File =',/,lx,A80) 

CALL CHECK__FILE (IFILETYPE, INFILE, lACCEPT) 
IF ( I ACCEPT. NE.O) GOTO 112 
ENDIF 

103 CONTINUE 

C 

C Modification 9/12/96: LET range hardwired: 

LETMINMG=1. OE-3 
LETMAXMG=1. lE+2 

1032 CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE (6, 1004) 

1004 FORMAT (' Enter minimum & maximum atomic numbers to be', 
& ' included in dose calculation:', 

& /, ' [Enter 0 0 cCARRIAGE RETURN> for full range', 

& ' included in the input flux file.]') 

101 CONTINUE 

READ ( * , * , ERR=1032 , IOSTAT=IERR) IMINTEMP, IMAXTEMP 

IF (IMAXTEMP. NE.O .and. IMAXTEMP . LT . IMINTEMP) THEN 
I2MIN=MIN { IMINTEMP, IMAXTEMP) 
I 2MAX=MAX (IMINTEMP, IMAXTEMP) 

ELSE 

I ZMIN= IMINTEMP 
I ZMAX= IMAXTEMP 
ENDIF 

IF (IZMIN.LT.O .or. IZMIN.Gt!92 
' & -or. I2MAX.lt. 0 .or. I2MAX.GT.92) THEN 

WRITE (6, 9002) I2MIN, IZMAX 
5002 FORMATdx,' Invalid atomic number (s) : ',215, 

& /,lx,' Please try again.') 

GOTO 101 

ENDIF 

IF (IZMIN.EQ.O .and. IZMAX. EQ.O) THEN 
WRITE (6, 1039) 

1039 FORMAT (' Nominal Z range from input flux file used.') 
ELSEIF (IZMIN.EQ.O .and. IZMAX. NE.O) THEN 
WRITE (6, 1038) IZMAX 
1038 FORMATC Minimum 2 value from input flux file; Maximum Z =',I3 



.NE^Band. IZMAX.EQ.O) THEN 
)3 7)^2MIN 



ELSEIF (I2MIN. 

WRITE(6, 103' 

1037 FORMATC Minimum Z =',I3,'; Maximum Z value from', 
& ' input flux file. ' ) 

ELSE 

WRITE (6, 1040) IZMIN, IZMAX 
1040 FORMATdx,' Dose accumulated for elements', 
& /,lx,I3, ' </= Z </= M3) 

ENDIF 



C 12/1/97: EMIN,EMAX hardwired. Keep source code here in case requested 

C by beta- testers . 

EMINCUT=0.1 

EMAXCUT=1. OE+5 

C 

C 105 CONTINUE 

C CALL RETRY_INPUT(IERR) 

C EMAXCUT=1.0E+24 
C WRITE (6, 1005) 

C 1005 FORMATC Enter minimum particle energy (in MeV/nuc) ' , 
C & ' to be included in accumulating the' 

C & /,' dose calculation:') 

C 

C READ{*, *,ERR=105, IOSTAT=IERR) EMINCUT 

C IF (EMINCUT.lt. 0 . ) THEN 

C WRITE (6, 9005) EMINCUT 

C 9005 FORMATdx,' Invalid minimum energy value: ',E13.6, 

C & /,lx,' Please try again.') 

C GOTO 105 

C ENDIF 

C 

C WRITE (6, 1051) EMINCUT 

C 1051 FORMAT(/,' Dose accumulated for', 

C & ' nuclei with energy > ',F8.3,' MeV/nuc.') 

C 

MATERIAL=' SILICON' 
WRITE (6, 1007) MATERIAL 

1007 FORMAT(/,' Dose calculated in ' ,A12) 

1017 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6,1008) 

1008 FORMAT(/,' Enter name of output file: ', 

& /,' Note: According to CREME96 naming conventions,', 

& ' should be something. dse ' ) 

ILONG= INDEX (INFILE, ' . ' ) 
IF (ILONG.NE.O) THEN 

DEFAULT_NAME= INFILE (1 : ILONG) // ' DSE' 

ELSE 

DEFAULT_NAME=INFILE//' .DSE' 
ENDIF 



WRITE (6, 1028) DEFAULT_NAME ( 1 : 79) 
1028 FORMATC Suggested name : ' , /, Ix, A79, 

& /,' Hit RETURN if this is acceptable.') 



1018 CONTINUE 



READ(*,1014,ERR^^W, IOSTAT=IERR) OUTFILE 
IF (OUTFILE. EQ. I^^IK) OUTFILE=DEFAULT_NAME 



WRITE (6, 1009) OUTFILE 

1009 FORMAT (' Output Flux File =',/,lx,A80) 

CALL CHECK_NAME_CONFLICT ( INFILE , OUTFILE , lACCEPT) 
IF (lACCEPT.NE.O) GOTO 1017 

CALL CHECK_OUTPUT_FILE (OUTFILE, lACCEPT) 
IF (lACCEPT.NE.O) THEN 
WRITE (6, 1010) INFILE (1 : 75) 
WRITE(6,1011) 0UTFILE(1:75) 
WRITE (6, 1012) 

1010 FORMAT (Ix,' INPUT file = ',/,5x,A75) 

1011 FORMAT (Ix,' Previous try at OUTPUT name = ',/,5x 

1012 FORMATdx, ' Try again, ie . , nevmame .DSE' ) 
GOTO 1018 

ENDIF 



RETURN 
END 




c 
c 
c 
c 
c 
c 
c 
c 
c 
c 



SUBROUTINE INi:^^NFILE, LETMINMG, LETMAXMG, 

^ ^^IZMIN, I2MAX,EMINCUT,EMAXCUT,MA^IAL,0UTFILE 

& IDIFSPEC) 



Subroutine for initializing input parameters to LETS PEC program 
m CREME96. This version only allows SILICON devices. 

Modifications 11/8/96: Allow 0 for input 12 values to select 

either lowest or highest from input flux 
file. 

Modification 10/31/96: option of differential LET spectrum added. 



C Modifications 9/12/96: LETMINMG, LETMAXMG hardwired; 

^ allow user to specify minimum energy in 

^ flux accumulation. 

C 

IMPLICIT NONE 

INTEGER*4 IZMIN, IZMAX, IMINTEMP, IMAXTEMP, IFILETYPE, lACCEPT 
REAL*4 LETMINMG, LETMAXMG, LETMINTEMP,LETMAXTEMP 
REAL*4 EMINCUT,EMAXCUT 

CHARACTER* 8 0 INFILE , OUTFILE , DEFAULT_NAME 

CHARACTER* 12 MATERIAL 

CHARACTER* 1 IBLANK 

DATA IBLANK/ ' ' / 

INTEGER*4 lERR, IDIFSPEC , ILONG 

DATA IERR/0/ 

C 

WRITE (6, 1000) 

1000 FORMAT {' CREME96 IONIZING RADIATION ENVIRONMENT MODEL', 
& /,' --> INTEGRAL Linear Energy Transfer (LET)', 

& ' Spectrum Calculation') 
WRITE{6, 1001) 

1001 FORMATC This program will transform the input differential', 
& ' particle energy spectra from' , 

& /,' CREME96 into an LET spectrum, ie . , ' , 
& ' particle flux vs. LET [in MeV-cm2/g] ' , 

& /,' as appropriate for SEU calculations with CREME96. Before' 
& ' running this' , ' 
& /,' program, you must do:', 
&//, ' FLUX ' , 

& ' to generate the particle' 

& ' environment outside the spacecraft; and' 

& / , ' TRANS ' , 

& ' to transport fluxes through the spacecraft shielding ' 
&//,' NOTE: Before running this or any other CREME96 programs' 
& ' please define three ' , 
& /, ' logicals: ' ,/, 

& /,4x,' CREME96 as the directory where CREMES6 source', 

& ' & executables reside.', 

& /,4x,' CR96TABLES as the directory in which CREME96 data' 
& ' tables reside. ' , ' 

& /,4x,' USER as the directory in which cutout files' 

& ' should be written.', 

& //,' Now begin specification of the LETSPEC^DRIVHR inputs: ') 
INFILE= ' 



112 CONTINUE 



CALL retry_inpi:^^:rr) 

WRITE(6, 1002) 
1002 FORMATC Enter name of file containing', 

& ' CREME96 particle fluxes, ie. something. TFX ' , 

& /, ' from TRANS or' , 

& ' (for zero shielding) something . FLX from FLUX' 

& / , ' or something.tr* from TRP:') 

READ (*, 1014, ERR=112, lOSTAT-IERR) INFILE 
1014 FORMAT (A80) 

IF (INFILE. EQ.IBLANK) THEN 
WRITE (6, 1914) 

1914 FORMATdx,' You must specify an input .FLX file here,', 

& ' either from TRANS or' , 

& /,lx,' (in the case of zero shielding) from', 

& ' FLUX . ' , 

& ' Please try again.',/) 

GOTO 112 

ELSE 

IFILETYPE=4 
WRITE (6, 1020) INFILE 
1020 FORMATC Input Flux File =',/,lx,A80) 

CALL CHECK_FILE (IFILETYPE, INFILE, lACCEPT) 
IF (lACCEPT.NE.O) GOTO 112 
ENDIF 

103 CONTINUE 

C 

C Modification 9/12/96: LET range hardwired: 

LETMINMG=1.0E-3 
LETMAXMG=1 . lE+2 

C 

C Following code obsolete 9/12/96: 
C 

C WRITE(6,1003) 

C 1003 FORMAT (/,' Enter minimum Sc maximum LET values (in MeV-cm2/mg) 

C & // ' [Recommended for most SEE applications:' 

^ & //' minimum LET = l.OE-3 MeV-cm2/mg 

^ ^ //' maximum LET = 1 . lE+2 MeV-cm2/mg] 

C Sc /,' NOTE THE UNITS USED HERE -- per milligram!', 

C Sc Enter 0 0 <CARRIAGE RETURN> for recommended defaults.)') 

C ACCEPT *, LETMINTEMP,LETMAXTEMP 

C LETMINMG=MIN(LETMINTEMP,LETMAXTEMP) 

C LETMAXMG=MAX { LETMINTEMP , LETMAXTEMP ) 

C IF ( (LETMINMG.EQ. 0. ..and. LETMAXMG . EQ . 0 . ) 

C & .or. ( LETMAXMG. LE.LETMINMG) ) THEN 

C LETMINMG:= l.OE-3 

C LETMAXMG=l.lE+2 

C ENDIF 

C IF (LETMINMG.lt. 0 . .or. LETMAXMG . LT . 0 . 

C & .or. LETMINMG.EQ. LETMAXMG) THEN 

C WRITE (6, 9001) LETMINMG , LETMAXMG 

C 9001 FORMATdx,' Invalid LET value (s) : ' , E13 . 6 , 2x, E13 . 6 , 

^ ^ /,lx,' Please try again.') 

C GOTO 103 

C ENDIF 

CC WRITE (6, 1031) LETMINMG , LETMAXMG 
1031 FORMAT(/,' Integral LET spectrum accumulated for ', 

& /,lx,E12.5,' </= LET </= ',E12.5,' MeV- cm2 /mg ' , / ) 



1032 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1004) 

1004 FORMAT (' Enter minimum & maximum atomic numbers to be', 
& ' included in integral LET spectrum:', 

& /,' [Enter 0 0 <CARRIAGE RETURN> for full range', 

& ' included in the input flux file.', 

& /, ' NOTE: in general', 

& ' protons (Z=l) should NOT be included in the', 

& ' LET spectrum',/,' for most SEU calculations.]') 

101 CONTINUE 

READ(*, *,ERR=1032,IOSTAT=IERR) IMINTEMP, IMAXTEMP 

IF ( IMAXTEMP. NE.O .and. IMAXTEMP . LT . IMINTEMP) THEN 
IZMIN=MIN( IMINTEMP, IMAXTEMP) 
I ZMAX=MAX (IMINTEMP, IMAXTEMP) 

ELSE 

I ZMIN= IMINTEMP 
I ZMAX= IMAXTEMP 
ENDIF 




IF (IZMIN.LT.O .or. IZMIN.GT.92 
y & .or. IZMAX.LT.O .or. IZMAX.GT.92) THEN 

WRITE (6, 9002) IZMIN, IZMAX 
y 9002 FORMATdx,' Invalid atomic number (s) : ',215, 

O & /,lx,' Please try again.') 

nJ GOTO 101 

C3 ENDIF 

LIJ 

U IF (IZMIN. EQ.O .and. IZMAX. EQ.O) THEN 

s WRITE (6, 1039) 

y, 1039 FORMATC Nominal Z range from input flux file used.',/) 
pj ELSEIF (IZMIN. EQ.O .and. IZMAX. NE.O) THEN 

jrj WRITE(6,1038) IZMAX 

[7 1038 FORMATC Minimum . Z value from input flux file; Maximum Z =',I3) 
[f^, ELSEIF (IZMIN. NE.O .and. IZMAX. EQ.O) THEN 

WRITE (6, 1037) IZMIN 
1037 FORMATC Minimum Z =',I3,'; Maximum Z value from', 
& ' input flux file.') 

ELSE 

WRITE (6, 1040) IZMIN, IZMAX 
1040 FORMATdx,' Integral LET spectrum accumulated for elements', 
& /,lx,I3,' </= Z </= ',13,/) 

ENDIF 



105 CONTINUE 

CALL RETRY_INPUT(IERR) 
EMAXCUT=1.0E+24 
WRITE(6, 1005) 

1005 FORMATC Enter minimum particle energy (in MeV/nuc) ' , 



& 




' to be included in accumulating the' 


& 


/, 


' integral LET spectrum:', 


& 


/,' 


[NOTE: for most SEU applications,'. 


& 




the recommended value = 0.1 MeV/nuc . ' , 


& 




However, in some devices, ranging out of low- energy' 


& 




particles along very' , 


& 


/,' 


long RPP chords Cein lead to gross overestimates,', 


& 


1 


particularly for low-'. 



-4^^ devices in solar particle e^BLs. In' 
:ares, laraer minimum' . 



& thre ^ 

& ' these caW5, larger minimum' , 

& energy values (l-io MeV/nuc) should be explored.]') 



READ(*, *,ERR=105, IOSTAT=IERR) EMINCUT 
IF (EMINCUT. LT. 0. ) THEN 
WRITE (6, 9005) EMINCUT 
9005 FORMATdx,' Invalid minimum energy value: ',E13.6, 

& /,lx, ' Please try again.') 

GOTO 105 
ENDIF 

WRITE (6, 1051) EMINCUT 
1051 FORMAT(/,' Integral LET spectrum accumulated for', 
& ' nuclei with energy > ',F8.3,' MeV/nuc.') 



MATERIAL= ' SILICON' 
WRITE (6, 1007) MATERIAL 

1007 FORMAT!/,' LET spectrum calculated in ',A12) 

1017 CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE (6, 1008) 

1008 FORMAT(/,' Enter name of output file: ', 

& /,' Note: for standard input to CREME96 SEU routines', 

& ' must be something . LET' ) 

ILONG=INDEX{INFILE, ' . ' ) 
IF (ILONG.NE.O) THEN 

DEFAULT_NAME=INFILE (1 : ILONG) / / ' LET' 

ELSE 

DEFAULT_NAME=INFILE//' .LET' 
ENDIF 

WRITE (6, 1028) DEFAULT_NAME (1 : 79) 
1028 FORMATC Suggested name :',/, ix, A7 9 , 

& /, ' Hit RETURN if this is acceptable.') 

1018 CONTINUE 

READ (*, 1014, ERR=1017, IOSTAT=IERR) OUTFILE 
IF (OUTFILE. EQ.IBLANK) OUTFILE=DEFAULT_NAME 

WRITE (6, 1009) OUTFILE 
1009 FORMATC Output Flux File =',/,lx,A80) 

CALL CHECK_NAME_CONFLICT(INFILE, OUTFILE, lACCEPT) 
IF (lACCEPT.NE. 0) GOTO 1017 

CALL CHECK_OUTPUT_FILE (OUTFILE, lACCEPT) 
IF (lACCEPT.NE. 0) THEN 
WRITE (6 , 1010) INFILE (1 : 75) 
WRITE (6, 1011) OUTFILE (1:75) 
WRITE(6,1012) 

FORMATdx,' INPUT file = ',/,5x,A75) 

FORMATdx,' Previous try at OUTPUT name = ',/,5x,A75) 
FORMATdx,' Try again, ie . , newname . LET' ) 
GOTO 1018 
ENDIF 



1010 
1011 
1012 



1060 CONTINUE 
CALL RETRY_INPUT(IERR) 
WRITE (6, 1061) 

1061 FORMAT (/,' Do you want a DIFFERENTIAL LET spectrum also?: 
& ' {0=no; l=yes) ' , 

& NOTE: A differential LET spectrum is NOT necessary', 

& ' for SEU calculations.') 

READ(*, *,ERR=1060, IOSTAT=IERR) IDIFSPEC 
IF { IDIFSPEC. NE.l) IDIFSPEC=0 
IF { IDIFSPEC. EQ.O) WRITE ( 6 , 1062 ) 
IF ( IDIFSPEC. EQ.l) WRITE (6 , 1063 ) 

1062 FORMATC No differential LET spectrum will be created.',/) 

1063 FORMATC Differential LET spectrum also created. The file name', 
& ' will be the same as', 

& /, ' that of the integral LET spectrum, ' 

& ' but with extension .DLT',/) 



ru 



RETURN 
END 




SUBROUTINE INIP^MlNFILE , I PATH, UPATH, TARGET, 
& ^^SHIELDFILE,OUTFILE) 



Subroutine for initializing input parameters to transport routine 
in CREME96. This version only allows ALUMINUM shielding. 

Modified 06-13-96: to include shielding distribution 

Modified 11-13-96: gets shielding distribution from standard *.SHD 

file, as created with the SHIELDFILE_DRIVER program. 
Modified 11-17-97: to include . trp inputs 

IMPLICIT NONE 

INTEGER*4 IPATH, lULABEL, IFILETYPE, lACCEPT 
INTEGER*4 KFILETYPE , KACCEPT 
REAL* 4 UPATH 
CHARACTER*! I BLANK 
DATA IBLANK/' '/ 

CHARACTER*80 INFILE , SHIELDFILE , OUTFILE 
CHARACTER* 12 TARGET 

CHARACTER* 5 UNITS_LABEL 
DIMENSION UNITS_LABEL(4) 

DATA UNITS_LABEL/ ' g/cm2 ' , ' mils ' , ' cm ' , ' i ! ! ! ! ' / 

INTEGER* 4 lERR 
DATA IERR/0/ 

WRITE (6, 1000) 

000 FORMAT (' CREME96 IONIZING RADIATION ENVIRONMENT MODEL', 
& /,'--> NUCLEAR TRANSPORT PROGRAM') 

WRITE (6, 1001) 

1001 FORMAT (' This program will transport the ionizing', 



& '-radiation particle fluxes generated by', 

& /,' the CREME96 code through aluminum shielding', 

& ' of specified thickness. Before', 

Sc /,' running this program, you must do FLUX', 

& ' (ie, run CREME96 :FLUX_DRIVER) ' , 

& /, ' or TRP' , 

& ' (ie, run CREME96 :TRAPPED_PROTON_DRIVER) ' , 

& ' to generate',/,' the particle environment', 

& ' outside of the spacecraft. After running', 

& ' this program',/,' you will run other routines to', 

& ' calculate SEU rates. ', 



&//,' NOTE: Before running this or any other CREME96 programs', 
& ' please define three ' , 
& /, ' logicals: ' ,/, 

& /,4x,' CREME96 as the directory where CREME96 source', 

& ' Sc executables reside.', 

& /,4x,' CR96TABLES as the directory in which CREME96 data', 
Sc ' tables reside . ' , 

& /,4x,' USER as the directory in which output files', 

Sc ' should be written.', 

Sc //,' Now begin specification of the transport parameters: ') 
INFILE=r' 

112 CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE (6, 1002) 



1002 FORMAT(/,' Ent€^^^me of file containing', 
& ' CREN^^ particle fluxes : ' . 



particle f liixes 

& /,' ie., something. FLX, something . TRP, or something . TFX' ) 

READ (*, 1014, ERR=112, IOSTAT=IERR) INFILE 
1014 FORMAT (A80) 

IF (INFILE . EQ . IBLANK) THEN 
WRITE(6, 1914) 

1914 FORMATdx,' You must specify here EITHER a .FLX file', 

& ' from FLUX (FLUX_DRIVER) ' , 

& /,lx,' OR a .TR* file from a ', 

& ' TRP (TRAPPED_PROTON_DRIVER) . ' , 

& /,lx,' OR a .TFX file from a previous run of, 

& ' TRANS (TRANSPORT_DRIVER) . ' , 

& /,lx,' Please try again. ', /) 

GOTO 112 

ELSE 

IFILETYPE=:3 

WRITE (6, 1020) INFILE 

1020 FORMATC Input Flux File =',/,lx,A80) 
CALL CHECK_FILE (IFILETYPE, INFILE, lACCEPT) 
IF (lACCEPT.NE.O) GOTO 112 

ENDIF 

TARGET= ' ALUMINUM ' 

1021 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE(6,1003) TARGET(1:8) 
1003 FORMAT(/,' In what units will the ',A8, 

& ' shielding thickness be given? ' , 

& /, ' Enter 0, 1, or 2 : ' , 

^ /' ' 0 = g/cm**2' , 

^ /' ' 1 = mils 

^ / ' ' 2 = cm ' , 

& //,' (Note: 100 mils = 0.254 cm = 0.6858 g/cm**2 Al . ) ' ) 

READ(*, *,ERR=1021, IOSTAT=IERR) IPATH 
IF (IPATH. LT.O .or. IPATH. GT. 2) THEN 
WRITE (6, 9000) 

FORMATdx,' Illegal units specification. Please try again ') 
GOTO 1021 
ENDIF 

IULABEL= I PATH+ 1 

IF (IULABEL.GT.4) IULABEL=4 

WRITE (6, 9001) UNITS_LABEL(IULABEL) , TARGET 
9001 FORMATdx,' Shielding thicknesses : in ',A5,lx,A12) 

SHIELDFILE=' 
WRITE (6, 1035) 

1035^ FORMAT(/,lx, ' COMMENT ON SHIELDING VALUES: It is common', 
' practice for researchers dealing' , 
/,lx,' with total dose and dose-rate effects to', 

' determine part response with zero', 
/,lx,' shielding. For single event effects, on the ' 

' other hand, it is important to' , 
/,lx,' shield out low-energy particles', 

' which would never be encountered in a' , 
/,lx,' realistic situation. A nominal shielding', 
' thickness of 100 mils is therefore'. 



9000 



i^^^nmended for general compariso^^^r 



^ /i^^,' i^^^nmenaea tor general comparisof^^frposes 

fit ' However, a realistic' , 

& ' shielding' , 

fit /,lx,' distribution is essential for accurate SEU' 

& ' calculations in solar energetic', 

& /,lx,' particle ("flare") environments.') 

1036 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE(6,1004) 

1004 FORMAT (/, Ix, ' Enter shielding thickness: 

& /,lx' [Enter 0 if you wish to specify a file' 

& ' containing a shielding distribution.]') 

READ{*, *,ERR=:1036, IOSTAT=IERR) UPATH 

IF (UPATH. GT. 0 . 0) THEN 

WRITE(6, 1005) UPATH, UNITS_LABEL(IULABEL) , TARGET 

1005 FORMATC Shielding thickness = ' , FIO . 5, Ix, A5 , 5x, A12) 
ELSE 

1039 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1041) 

1041 FORMAT(/, Ix, ' Enter name of file containing shielding', 
& ' distribution. This file, which should', 

& /,lx,' be called something . SHD, has a special', 

& ' format. This file must have been', 

& /,lx,' created before running TRANS with the', 

& ' CREME96 command SHIELDFILE. ' ) 

READ (* , 1014 , ERR=1039 , IOSTAT=IERR) SHIELDFILE 
WRITE (6,1042) SHIELDFILE 

1042 FORMATC Shielding File =',/,lx,A80) 
KACCEPT=0 

C KFILETYPE=0 
KFILETYPE=7 

CALL CKECK_FILE (KFILETYPE , SHIELDFILE, KACCEPT) 
IF ( KACCEPT. NE. 0) GOTO 103 9 
ENDIF 



WRITE(6, 1008) 

1008 FORMAT(/,' Enter name of output file, ie., newname . TFX : ' ) 

1043 CONTINUE 

CALL RETRY_INPUT(IERR) 

READ (*, 1014, ERR=1043, IOSTAT=IERR) OUTFILE > 
WRITE (6, 1009) OUTFILE 

1009 FORMATC Output Flux File =',/,lx,A80) 

CALL CHECK__OUTPUT_FILE (OUTFILE, lACCEPT) 
IF (lACCEPT.NE.O) THEN 
WRITE(6,1010) INFILE(1:75) 
WRITE (6, 1011) OUTFILE (1:75) 
WRITE(6,1012) 

1010 FORMATdx, ' INPUT file = ',/,5x,A75) 

1011 FORMATdx,' Previous try at OUTPUT name = ',/,5x,A75) 

1012 FORMATdx,' Try again, ie., newname . TFX ' ) 
GOTO 1043 

ENDIF 



RETURN 
END 



ru 



SUBROUTINE INI S^J^ (MAXSH I ELD, COMMENT, 
& lUNITS , MATERIAL , NBINS , XTHICK , XPROB , 

& SHIELDFILE) 

C 

C Subroutine for initializing inputs to CREME96 program which 

C creates a shielding distribution file in standard format. 

C This version only allows ALUMINUM shielding. 

C 

IMPLICIT NONE 

INTEGER*4 lUNITS , NBINS , MAXSHIELD, lULABEL 

CHARACTER* 12 MATERIAL 

CHARACTER* 1 IBLANK 

DATA IBLANK/' '/ 

REAL*4 XTHICK ( 1 ) , XPROB ( 1 ) 

REAL* 4 XTEMP,PTEMP 

CHARACTER* 80 COMMENT, SHIELDFILE 

CHARACTER* 5 UNITS_LABEL 

DIMENSION UNITS_LABEL{4) 

DATA UNITS_LABEL/ ' g/cm2 ' , ' mils ' , ' cm ','!!!!!'/ 

C 

INTEGER*4 IERR,IACCEPT 
DATA IERR/0/ 

C 

WRITE (6, 1000) 

1000 FORMAT (' CREME96 IONIZING RADIATION ENVIRONMENT MODEL', 
& /,'--> Shielding distribution program') 

WRITE (6, 1001) 

1001 FORMAT (' This auxilliary program will use', 

& ' specified inputs to create a shielding ' 

& /,' distribution file with the format', 

& ' and header information expected by CREME96 . ' , 

&//,' NOTE: Before running this program please define', 

& n ' three logicals : ' , / , 

& /,4x,' CREME96 as the directory where CREME96 source', 

& ' & executables reside.', 

& /,4x, ' CR96TABLES as the directory in which CREME96 data' 
& ' tables reside.', 

& /,4x,' USER as the directory in which output files' 

& ' should be writtenl ' , 

& //,' Now begin specification of the shieldfile inputs: ') 



105 CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE (6, 1215) 

1215 FORMAT(/, Ix, ' Enter comment (80 characters max)', 
& ' for record-keeping in output file:') 

READ {*, 1218, ERR=105, IOSTAT=IERR) COMMENT 
1218 FORMAT (A80) 

1021 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (is, 1003) 

1003 FORMAT(/,' In what units will the shielding thickness be given? 



& ' Enter 0, 1, or 2 : ' , 

& /, ' 0 = g/cm**2' , 

& /, ' 1 = mils 

& /, ' 2 = cm 

& /,' (Note: 100 mils = 0.254 cm = 0.6858 g/cm**2 Al . ) ' ) 



READ(*, *,ERR=1021, IOSTAT=IERR) lUNITS 
IF (lUNITS.LT.O .or. IUNITS.GT.2) THEN 
WRITE (6, 9003) 

9003 FORMATdx,' Illegal units specification. Please try again.') 

GOTO 1021 
ENDIF 

IULABEL=IUNITS+1 

IF (IULABEL.GT.4) IULABEL-4 

^4ATERIAL= ' ALUMINUM ' 



WRITE (6, 9000) UNITS_LABEL ( lULABEL) , MATERIAL 
9000 FORMATdx,' Shielding thickness in' , A5, 2x, A12) 



NBINS=0 

WRITE (6, 1041) MAXSHIELD 

1041 FORMAT(/, ix, ' Now begin entry of shielding distribution: 
& /,lx,' Enter thickness (in the units specified above) and', 
& ' coverage factor (a number' , 
& /,lx,' between 0 and 1) then <CARRIAGE RETURN>' , 
& ' for each bin of the distribution.', 

& /,lx,' Terminate your input list with 0 0 <CARRIAGE RETURN> . ' , 
& /,lx,' The maximum number of bins allowed in the', 
& ' distribution is ',14,'.') 

1036 CONTINUE 
flj WRITE (6, 1042) 

1042 FORMAT (/, Ix, ' Enter shielding thickness and coverage factor: ') 
CALL RETRy_INPUT(IERR) 

READ (* , * , ERR=1036 , IOSTAT=IERR) XTEMP, PTEMP 
IF (XTEMP. GT. 0.0 .and. PTEMP . GT . 0 . 0) THEN 
NBINS=NBINS + 1 

IF ( NB INS, LE. MAXSHIELD) THEN 
XTHICK (NBINS) =XTEMP 
XPROB (NBINS) =PTEMP 

WRITE(6, 999) NBINS , XTHICK (NBINS) , UNITS_LABEL ( lULABEL) , 
& XPROB (NBINS) 

999 FORMATdx,' SHIELDING BIN ',14,' THICKNESS = ', 

& F10.4,lx,A5, ' FRACTION = ',F8.4) 

ELSE 

WRITE (6, 1043) NBINS , MAXSHIELD 

1043 FORMATdx,' Input terminated: No. input bins = ',15, 
^ / 1 Ix, ' Maximum allowed = ' , 15) 

GOTO 1050 
ENDIF 

ELSE 

WRITE (6, 1044) 

1044 FORMATdx,' Shielding distribution input completed.') 
GOTO 1050 

ENDIF 
GOTO 1036 

1050 CONTINUE 

SHIELDFILE=' 



112 



CONTINUE 

CALL RETRY_INPUT{IERR) 



WRITE(6, 1002) 

1002 FORMAT (/,' Enterliame of output shielding file: 

& ' ie., something. SHD (Your file must have', 

& /,' this extension in order', 

& ' to be accessbile by CREME96', 

& ' directory routines . ) ' ) 

READ (*, 1014, ERR=112, IOSTAT=IERR) SHIELDFILE 
1014 FORMAT (A80) 

IF (SHIELDFILE. EQ.IBLANK) THEN 
WRITE (6, 1914) 

1914 FORMATdx,' You must specify a filename here:', 

& /ilx, ' Please try again.',/) 

GOTO 112 

ELSE 

WRITE (6, 1020) ShieldFILE 
1020 FORMATC Output Shielding Distribution File =',/,lx,A80) 

CALL CHECK_OUTPUT_FILE (SHIELDFILE , lACCEPT) 
IF ( I ACCEPT. NE. 0) GOTO 112 
ENDIF 

RETURN 

END 



SUBROUTINE IN! 




I ZE_H I _UPS ETS ( LET_F I LE , XM , YM ,^^FUNNEL , NB I TS , 

IPARAM,PARAMS,XSECT_FILE, lENTER, 
DEVICE LABEL, REPORT FILE) 




C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

c- 
c 



Written by: 



Generates interactive dialogue to get necessary input parameters 
for heavy- ion upsets: 



Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka@crs2 . nrl . navy . mil 



IMPLICIT NONE 

CHARACTER* 80 LET_FILE, XSECT_FILE , REPORT_FILE 

CHARACTER* 40 DEVICE_LABEL 

REAL*4 XM,YM,ZM, FUNNEL, PARAMS,NBITS 

INTEGER*4 IPARAM, lACCEPT, IFILETYPE , lENTER 

CHARACTER*! IBLANK 

DATA IBLANK/' '/ 

DIMENSION PARAMS(4) 

INTEGER* 4 lERR 

DATA IERR/0/ 

IF (lENTER.EQ.l) THEN 

WRITE (6, 1000) 

1000 FORMAT (' CREME96 IONIZING RADIATION ENVIRONMENT MODEL', 
& /, ' --> Heavy- Ion- Induced Single Event Upset', 

& ' (SEU) Rate Calculation' ) 
WRITE(6, 1001) 

1001 FORMAT (' This program will use the integral LET ', 
& ' spectrum (something. LET, generated by 

& /,' the CREME96 codes) and device' 

& ' characteristics (input below) to calculate', 

& /, ' a heavy-ion induced SEU rate (in upsets/bit' 

& ' /sec or /day) . ' , 

& /,' Before running this program you must do:', 

& /,' FLUX to generate the environment', 

fit ' outside of the spacecraft;', 

& /,' TRANS to transport the particle fluxes', 

fic ' through shielding; and' , 

& /,' LETSPEC to create an integral LET spectrum.' 

& /,' For many devices and applications you should also do:', 

fic /,' PUP to calculate the rate', 

fi^ ' of proton- induced SEUs.', 

&//,' NOTE: Before running this or any other CREME96 programs', 
fii: ' please define three ' , 
• & /, ' logicals: ' , /, 

Sc /,4x,' CREME96 as the directory where CREME96 source', 

& ' fi^ executables reside . ' , 

fic /,4x,' CR96TABLES as the directory in which CREME96 data', 
& ' tables reside.', 

& /,4x, ' USER as the directory in which output files', 

& ' should be written. ' , 

& //,' Now begin specification of inputs for the'. 



' SEU rate 
LET FILE=' 



^^ulation: 



110 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1100) 

1100 FORMATC Enter name of integral LET spectrum file', 
& ' (something. LET) : ' ) 

READ{*, 1,ERR=110, IOSTAT=IERR) LET_FILE 
1 FORMAT (A80) 

IF (LET_FILE.EQ. IBLANK) THEN 
WRITE (6, 1914) 

1914 FORMATdx,' You must specify an input .LET file', 

& ' from LETSPEC__DRIVER here . ' , 

& ' Please try again. ' , /) 

CALL CHECK_FILE (IFILETYPE, LET_FILE, lACCEPT) 
GOTO 110 

ELSE 

IFILETYPE=5 

WRITE (6, 1110) LET_FILE 
1110 FORMATC Input LET File = ',/,lx,A80) 

CALL CHECK_F ILE{IFILETYPE,LET_FILE,IACCEPT) 
Q IF (lACCEPT.NE.O) GOTO 110 

kg ENDIF 

o 

fij 120 CONTINUE . 

PI CALL RETRY_INPUT{IERR) 

M WRITE (6, 1120) 

[7 1120 FORMATdx,' Enter name for an output file, which will', 
I & ' record the inputs and results. ', 

& /,lx,' (If no report file is wanted, hit <CARRIAGE RETURN> . ) ' ) 
121 CONTINUE 

READ ( * , 1 , ERR=12 0 , IOSTAT=IERR) REPORT_FILE 

IF (REP0RT_FILE(1:2) .EQ'. ' -1' ) GOTO 110 

IF (REPORT_FILE . EQ . IBLANK) THEN 
REPORT_FILE= ' NULLFILE ' 
WRITE(6,1121) 

1121 FORMATdx,' No report file created by HI_UPSET_DRIVER . ' ) 
ELSE 

CALL CHECK_OUTPUT_FILE (REPORT_FILE , lACCEPT) 
IF (lACCEPT.NE.O) GOTO 121 
WRITE (6, 1122) REPORT_FILE(l:79) 

1122 FORMATdx,' Report file created by HI_UPSET_DRIVER : ', 
& /,lx,A79) 

ENDIF 

ENDIF 

CALL GET_HI_XS_INPUTS (DEVICE_LABEL, XM, YM, ZM, FUNNEL, NBITS , 
& IPARAM, PARAMS,XSECT_FILE) 

IF (lENTER.EQ.i .and. DEVICE_LABEL (1 : 2 ) . EQ. ' -1 ' ) GOTO 120 

RETURN 
END 



SUBROUTINE IN^^^IZE_PROTON_UPSETS (PROTON_FIl]^^ITS , 

^ IPARAM, PARAMS , XSECT_FILE , 

^ lENTER, 

^ DEVICE LABEL, REPORT FILE) 

C 
C 

C Generates interactive dialogue to get necessary input parameters 

C for proton- induced SEU rate; 

C 

C Written by: Allan J. Tylka 

C Code 7654 

C Naval Research Laboratory 

C Washington, DC 20375-5352 

C tylka®crs2 . nrl . navy . mil 

C 

C Last update; 20 August 1996 

C 

C 

C 

IMPLICIT NONE 

CHARACTER*80 PROTON_FILE, XSECT_FILE, REPORT_FILE 
CHARACTER*4 0 DEVICE_LABEL 
REAL*4 PARAMS, NBITS 

INTEGER*4 IPARAM, lENTER, IFILETYPE , lACCEPT 

DIMENSION PARAMS (4) 

CHARACTER*! IBLANK 

DATA IBLANK/' '/ 

INTEGER*4 lERR 

DATA IERR/0/ 

IF (lENTER.EQ.l) THEN 

WRITE(6,1000) 

1000 FORMAT {' CREME96 IONIZING RADIATION ENVIRONMENT MODEL', 
& /,' --> Proton- Induced Single Event Upset', 

Sc ' (SEU) Rate Calculation' ) 
WRITE(6,1001) 

1001 FORMAT (' This program will use the differential', 
& ' proton flux generated by CREME96', 

& /,' [something. TFX or (for zero shielding) something . FLX' , 

& ' or . tr*] ' , 

& ' and device characteristics', 

& /,' [input below] to calculate a proton- induced' , 

& ' SEU rate {in SEUs/bit/sec or /day) . ' , 

& /,' NOTE: the .TFX/. FLX file may contain other species', 

& ' in addition to protons, but', 

& /,' they will be ignored here.', 

& //,' Before running this program, you must do:', 

& /, ' FLUX to generate the particle', 

& ' environment outside of the spacecraft;', 

& /, ' TRANS to transport the', 

& ' particle fluxes through shielding.', 

& y,' For many devices and applications', 

& ' you should also do: ', • ' 

& /,' LETSPEC and HUP to calculate the rate of, 

& ' heavy- ion- induced SEUs.', 

&//,' NOTE: Before running this or any other CREME96 programs', 
& ' please define three ' , 
& /, ' logicals: ' , /, 

& /,4x, ' CREME96 as the directory where CREME96 source', 



ec^l^les reside.', ^^1^ 



& ' & exec 

& /,4x,' CR 9 6 TABLES^ as the directory in which CR^1E96 data', 
& ' tables reside.', 

& /,4x,' USER as the directory in which output files', 

& ' should be written.', 

&' //,' Now begin specification of inputs for the', 
& ' proton-SEU rate calculation: ') 



110 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6, 1100) 

1100 FORMAT (' Enter name of flux file containing the proton spectrum' 
& ' { some thing. TFX or .FLX):') 

READ(*,1,ERR=110,IOSTAT=IERR) PROTON_FILE 
1 FORMAT (A80) 

IF (PROTON_FILE.EQ.IBLANK) THEN 
WRITE{6,1914) 

1914 FORMATdx,' You must specify either an input .TFX file', 

& ' from TRANSPORT_DRIVER or' , 

& /,lx,' (in the case of zero shielding) an input', 

& ' .FLX file from FLUX_DRIVER' , 

& /,lx,' Please try again.',/) 

GOTO 110 

ELSE 

IFILETYPE=4 

WRITE (6, 1110) PROTON_FILE 
1110 FORMAT (' Input Particle Flux File (containing protons) = ' 

& ,/,lx,A80) 

CALL CHECK_FILE (IFILETYPE, PROTON_FILE, lACCEPT) 
IF (lACCEPT.NE. 0) GOTO 110 
ENDIF 

120 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1120) 

1120 FORMATdx,' Enter name for an output file, which will', 
Sc ' record the inputs and results. ', 

& /,lx, ' (If no report file is wanted, hit <CARRIAGE RETURN>.)') 

121 CONTINUE 

READ(*,1,ERR=120, IOSTAT=IERR) REPORT_FILE 

IF {REP0RT_FILE(1:2) .EQ. ' -1' ) GOTO 110 

IF (REPORT_FILE.EQ. IBLANK) THEN 
REPORT_FILE= ' NULLFILE ' 
WRITE(6, 1121) 

1121 FORMATdx,' No report file created by HI_UPSET_DRIVER. ' ) 
ELSE 

CALL CHECK_OUTPUT_FILE (REPORT_FILE , lACCEPT) 
IF (lACCEPT.NE. 0) GOTO 121 
WRITE (6, 1122) REP0RT_FILE(1:79) 

1122 FORMATdx,' Report file created by HI_UPSET_DRIVER : 
& /,lx,A79) 

ENDIF 



ENDIF 



CALL GET_PROTON_XS_INPUTS (DEVICE_LABEL, 




NBITS, IPARAM, PARAMS, ;^P'_FILE) 
IF (lENTER.EQ.l .and. DEVICE LABEL (1 : 2) .EQ. ' -1 ' ) GOTO 120 



RETURN 
END 



c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c- 

c 



c 
c 
c 
c 
c 



& 



SUBROUTINE IN^^i^TE_HEAVY_ION_UPSETS (NPTS , LEl^^.UX , XSECT, 

XM,yM, ZM, FUNNELM, 
SEU_RATE) 

Subroutine for performing numerical integration over the soft-turn 
on in the heavy- ion LET -dependent cross -section 



INPUTS ; 



NPTS 
LETG 
FLUX 



OUTPUT: 
Written by: 



= number of datapoints in input array 
= array containing LET values in MeV-cm2/g 
= array containing the flux (in /m2-s-sr) 
of particles with LET > LETG 
XSECT = array of cross -section values (in l.OE-8 cm2/bit) 

corresponding to the LETG values 
XM,YM,2M = device dimensions in microns 

(ZM = depth of sensitive area, 

typically 0.5-2.0 microns) 
FUNNELM = funnel length (in microns) 

SEU_RATE = SEU rate in SEUS/s/bit 

Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 . nrl . navy . mil 



Last update: 24 October 1996 



IMPLICIT NONE 

INTEGER*4 NPTS , NPTSMAX , K 

PARAMETER (NPTSMAX= 5000) 

REAL * 4 LETG , FLUX , XS ECT , XM , YM , ZM , FUNNELM , S EU_RATE , QC , AFRAC , 

UPSl , UPS 2 , DELTA_U, DELTA_U_SAVE , AFRACMAX 
DATA AFRACMAX/0.99/ 

DIMENSION LETG (1) , FLUX (1) , XSECT (1) 
DIMENSION QC (NPTSMAX) , AFRAC (NPTSMAX) 
INTEGER*4 NERRORS , QPTS , KLAST 
LOGICAL QUIET 
DATA QUIET/. true./ 

Integrates over the soft turn-on in the heavy- ion SEU cross-section 
by calculating rate at each critical charge value and adding 
together in a sum weighted by the corresponding cross-section 



CALL SAMPLE_SOFT_TURNjON (NPTS , NPTSMAX , 
& LETG, XSECT, XM,YM, ZM, FUNNELM, 

& AFRACMAX, 
& QPTS, QC, AFRAC) 



Now calculate upsets for each critical charge interval 
NERRORS =0 
SEU_RATE=0 . 0 

CALL GET_UPSET(XM,YM,ZM, FUNNELM, QC(1) , NPTS , LETG, FLUX, UPSl) 
DO 200 K=1,QPTS-1 



CALL GET_UE^^XM,YM, ZM,FUNNELM,QC(K+1) , NPtIJ^G, FLUX, UPS2 ) 
DELTA_U= (UPS^UPS2) *0 . 5* (AFRAC (K) +AFRAC (K+1) ) 

IF {DELTA_U.LT.O. ) THEN 

C 

C 10/24/96: The original versions of CREME and CREME96 contained 

C an occasional bug here. The SEU rate should, of course, 

C be a monotonically decreasing function of increasing critical 

C charge. Due to poor sampling around LETs corresponding to the peaks 

C in the differential pathlength distribution, occasionally 

C the rates returned from GET_UPSET did not show this. This problem 

C has now (I believe) been fixed, by explicitly installing a 

C higher density sampling around these values. The following 

C error message should therefore NEVER be activated. AJT 

NERRORS =NERRORS + 1 

IF (.not. quiet) WRITE (6 , 9999) DELTA_U,K, QC (K) , UPSl, 
& K+1,QC(K+1) ,UPS2, 

& AFRAC (K) , AFRAC (K+1) 

9999 FORMAT dx,' ERROR in SEU vs. QC : DELTA_U = ',E13.6, 

& /,lx,' K ,QC(K) ,UPS1: ', 16 , Ix, E13 . 6 , 5x, E13 . 6 , 

& /,lx,' K+1,QC(K+1) ,UPS2 : 16 , Ix , E13 . 6 , 5x , E13 . 6 , 

& /,lx,' AFRAC (K) , AFRAC (K+1) : .',E13.6, 5x,E13.6, 

& /,lx,' PLEASE NOTIFY tylka@crs2.nrl.navy.mil.') 

ELSE 

DELTA_U_SAVE=DELTA_U 
ENDIF 

C Protect against bug of undetermined origin: 

I F { DELTA_U . LT . 0 . ) DELTA_U=DELfA_U_S AVE 
SEU_RATE = SEU_RATE +DELTA_U 

IF (AFRAC (K+1) .GE.AFRACMAX) THEN 
C Plateau in cross- section reached. Terminate numerical 

C integration over soft turn-on. 

KLAST=K+1 
GOTO 210 
ENDIF 

C Store SEU rate for next integration step: 

UPS1=UPS2 

200 CONTINUE 

KLAST=QPTS 

210 . CONTINUE 



CALL GET_UPSET(XM, YM,ZM,FUNNELM,QC(KLAST) , NPTS , LETG, FLUX, UPSl) 
IF (UPSl.LT.O.) UPS1=0.0 
SEU_RATE=SEU_RATE+UPS1*AFRAC (KLAST) 

t 

IF (. not. quiet. and. NERRORS. GT. 0. ) WRITE (6, 9990) QPTS, NERRORS 
9990 FORMAT (IX,' Debug I_H__I_U: NPTS, NERRORS = ',215) 
RETURN 
END 




c 



& 

St 



9998 



SUBROUTINE S;^fe_SOFT_TURN_ON (NPTS , NPTSMAX , 

LETG,XSECT,XM, YM, ZM, FUNNELM, 

AFRACMAX, 

QPTS,QC,AFRAC) 

IMPLICIT NONE 

INTEGER*4 NPTS , NPTSMAX , QPTS 

REAL*4 LETG,XSECT,XM,YM,ZM,FUNNELM,AFRACMAX,QC AFRAC 
DIMENSION LETGd) ,XSECT(1) ,QC{1) ,AFRAC{1) 
INTEGER*4 K, NSAMPMAX , KMOD , KLASTO , KFIRST, KLAST 
REAL* 4 AFRACTEST 
DATA NSAMPMAX/100/ 



C Comparison of SEU rates for various devices showed that sampling 

C the turn on region of the cross-section curve in 100-200 points 

C should be adequate. NSAMPMAX is used to reduce the number of 

C points in the cross-section sampling to this level 

C 

QPTS=1 

DO 50 K=2,NPTS 

IF (XSECT(K) .GT.O.) THEN 
QPTS=QPTS+1 
KLASTO=K 

AFRACTEST=XSECT (K) / (XM*YM) 

IF ( AFRACTEST. GE.AFRACMAX) GOTO 51 
ENDIF 

50 CONTINUE 

51 CONTINUE 
KMOD=QPTS /NSAMPMAX 

IF (KMOD.LE.l) KM0D=1 

QPTS=1 
KFIRST=1 

DO 100 K=2,NPTS,KM0D 

IF {XSECT(K) .GT.O. ) THEN 

IF (QPTS.EQ.l) KFIRST=K-1 

Now convert LET values in cross-section table to critical 
C charges, in picocoulombs . See SEE Notebook #1, p 5 

QPTS=QPTS+1 

QC(QPTS) =LETG(K) * (ZM+FUNNELM) *1 . 033E- 5 
C Also scale cross -section value by nominal area: 

AFRAC (QPTS ) =XSECT (K) / (XM*YM) 
KLAST=K 

IF (AFRAC (QPTS) .GE.AFRACMAX) GOTO 101 
IF (QPTS.EQ.NPTSMAX) THEN 
WRITE (6, 9998) QPTS 

FORMAT dx,' CAUTION from INTEGRATE_HEAVY_ION_UPSETS : ' , 
^ Maximum Array size reached: 

^ /, ' QPTS = ' , 14) 



GOTO 101 
ENDIF 
ENDIF 

100 CONTINUE 

101 CONTINUE 

- Make sure we catch the plateau: 

IF (KLAST. LT.KLASTO) THEN 

IF (QPTS.LT.NPTSMAX) THEN 
QPTS=QPTS+1 




AFRAC (Q^W=XSECT (KLASTO ) / (XM*YM) 
QC (QPTS ) =i.ETG (KLASTO ) ♦ ( ZM+FUNNELM) * 1 . 03 
ENDIF 

ELSE 

KLASTO=KLAST 
ENDIF 

Also store last value with zero cross-section 
QC{1) =LETG(KFIRST) * (ZM+FUNNELM) *1.033E-5 
Following should be zero; 
AFRAC (1) =XSECT (KFIRST) / (XM*YM) 



RETURN 
END 



SUBROUTINE INT: 



C 
C 
C 
C 

c 

c 

c 

c 
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E_PROTON_UPSETS (NPTS , EN, FLUXlBBfCT, SEU_RATE) 



Performs numerical integration of flux X cross-section integral 
for proton- induced SEUs. 

Inputs : NPTS = number of points in input arrays 
EN = array of proton energies (in MeV) 
FLUX = array of proton differential flux 

(in protons/m2-s-sr-MeV) , evaluated at EN 
XSECT= array of SEU cross-sections, in l.OE-12 cm2/bit, 
evaluated at EN 
Output: SEU_RATE = #SEUs/s/bit 



Written by: Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka@crs2 . nr 1 . navy . mi 1 

Last update: 29 March 1996 



IMPLICIT NONE 

INTEGER* 4 I , NPTS 

REAL*4 EN,FLUX,XSECT 

REAL*4 FOURPI,DE,XINT,SEU_RATE 

DIMENSION EN(1) ,FLUX(1) ,XSECT(1) 



FOURPI=16 .0*ATAN(1.0) 

SEU_RATE=0.0 

DO 200 I=1,NPTS-1 

DE=EN(I+1) -EN(I) 

XINT=0.5*(FLUX(I)*XSECT(I) + FLUX ( I + l ) *XSECT ( I + l) ) 
S EU_RATE = S EU_RATE +X I NT * DE 
200 CONTINUE 



C 

C Now apply some factors : 

C Convert flux from /m2 to /cm2 : l.OE-4 

C Cross-section in units of l.OE-12 cm2 

C Effective geometry factor = 4pi 

C Planar detector has a geometry factor of 2pi (top & bottom) ; 

C but the loss of projected area due to the obliquity factor is 

C compensated for by the sec-theta increase in pathlength through 

C the sensitive volume. 



SEU_RATE=F0URPI*SEU__RATE*1 . OE-16 

RETURN 

END 



REAL*4 FUNCTI^^NTERPOLATE_XSECT_TABLE (NSV, XV^^, E) 

C 

C Function does linear interpolation in a table to evaluate 

C the SEU cross -section 

C 

C Inputs: NSV: number of entries in the table 

C XV: X- coordinates of table 

C yV: y-coordinates of table 

C E: x-value at which cross-section is required 

C Output: SEU cross -section 

C 

C NOTE: returned value will be zero at E < XV (l) 

C returned value will be YV(NSV) at E > YV(NSV) 

C otherwise, linearly- interpolated. It is the user's 

C responsibility to make sure the table is ordered as 

C monotonically- increasing XV values. 

C 

C 

C Written by: Allan J. Tylka 

C Code 7654 

C Naval Research Laboratory 

C Washington, DC 20375-5352 

C tylka®crs2 . nrl . navy . mil 

C 

C Last update: 29 March 1996 

C 

C 

C 

IMPLICIT NONE 
INTEGER*4 NSV, I 
REAL*4 XV,YV,E 
DIMENSION XV{1),YV(1) 

INTERPOLATE_XSECT_TABLE = 0. 

IF (NSV.LE.O .OR. E.LT.XV{1)) RETURN 

IF (E.GT.XV(NSV) ) THEN 

INTERPOLATE_XSECT_TABLE=YV (NSV) 

ELSE 

DO 100 1=2, NSV 

IF (E.LT.XVd)) THEN 
INTERPOLATE_XSECT_TABLE= 
& YV(I-1) + (E-XV(I-1) )*(YV(I)-yV(I-l) )/{XV(I) -XV(I-l) ) 

GOTO 200 
ENDIF 

100 CONTINUE 
200 CONTINUE 

ENDIF 

IF ( INTERPOLATE_XSECT_TABLE . LT . 0 . ) INTERPOLATE_XSECT_TABLE=0 . 0 

RETURN 
END 



PROGRAM LETSPE' 
IMPLICIT NONE 

CHARACTER*80 INFILE , OUTFILE 

REAL*4 LETMINMG,LETMAXMG,LETMIN,LETMAX,ELOWER,EUPPER 
REAL*4 EMINCUT,EMAXCUT 
CHARACTER* 12 TARGET 

INTEGER* 4 MARR,NELM, LARR, IZMIN, I2MAX, IZLO, IZUP,M,L 
PARAMETER (MARR=5000 , NELM=92 , LARR=1002 ) 

REAL*4 INPUT_FLUX (NELM, MARR) , SPECT (LARR) , DIFSPEC (LARR) 
INTEGER* 4 VERSION_NUMBER, PROGRAM_CODE , IDIFSPEC 

C 
C 

C Get parameters of LETSPEC calculation: 

C 

CALL INILET{INFILE,LETMINMG,LETMAXMG, IZMIN, IZMAX , EMINCUT, 

* EMAXCUT, TARGET, OUTF I LE, IDIFSPEC) 

C Unload input particle flux file into array: 

C 

CALL UNLOAD_PARTIAL_FLUX (INFILE, IZMIN, IZMAX , EMINCUT, EMAXCUT, 

* ELOWER,EUPPER,M, IZLO, IZUP, 

* INPUT_FLUX) 

^ C Now do integral LET spectrum calculation: 

C 

CALL CREME96__LETSPEC(LETMINMG,LETMAXMG, TARGET, 

* ELOWER,EUPPER,M, IZLO, IZUP, 
y & INPUT_FLUX, 

& VERSION_NUMBER, PROGRAM_C0DE , IDIFSPEC, 

H' & LETMIN,LETMAX,L, SPECT, DIFSPEC) 

s C 

M. c 

nJ C Now write integral LET spectrum to output file: 

W ^ 

CALL OUTPUT_CREME96_LETSPEC(LETMIN,LETMAX,L, 
^ * IZLO, IZUP, EMINCUT, EMAXCUT, TARGET, 

%J * VERS I ON_NUMBER , PROGRAM_CODE , 

* INFILE, 

* SPECT, 

* OUTFILE) 

C 

C Also output differential LET spectrum 



P 

rii 



c 



IF (IDIFSPEC. EQ. 1) 
*CALL 0UTPUT__CREME96_DIFLET (LETMIN, LETMAX, L, 

* IZLO, IZUP, EMINCUT, EMAXCUT, TARGET, 

* VERS ION_NUMBER , PROGRAM_CODE , 

* INFILE, 

* DIFSPEC, 

* OUTFILE) 



STOP 
END 



SUBROUTINE LOiHrF (GTRANSFILE) 



Loads geomagnetic transmission function from specified file 
into a common block for later use . 

IMPLICIT NONE 
CHARACTER* 80 GTRANSFILE 

INTEGER*4 NGTF, IGTF, I , IGTFUNIT, IVER, NHEADER, STAT, CREME96 OPEN 
REAL*4 R,GTF ~ 
PARAMETER (NGTF=1001) 

COMMON/GTFDAT/IGTF, R (NGTF) , GTF (NGTF) 
LOGICAL IEXIST,CREME96_INQUIRE 
DATA IGTFUNIT/15/ 

First see if GTRANSFILE exists: 

INQUIRE {FILE= ' USER : ' //GTRANSFILE , EXIST=IEXIST) 
iexist = creme96_inquire (gtransf ile, 'user' ) 
IF (.NOT. IEXIST) THEN 

WRITE (6, 999) GTRANSFILE 

FORMAT (' Geomagnetic Transmission File = ',/, 
: lx,A80,/' not found. Job aborted.') 

STOP 
ENDIF 

CALL CHECK_CREME96_VERSION (GTRANSFILE, IVER) 

OPEN (UNIT=IGTFUNIT, READONLY, SHARED, STATUS= ' OLD' , 
& FILE= ' USER //GTRANSFILE) 

Stat = creme96_open (gtransf ile, 'user' , igtfunit, 'old' ) 

Get pass header lines: 

IF (IVER. EQ. 101) THEN 

READdGTFUNIT, *) 

READ ( IGTFUNIT , * ) 
ELSEIF ( IVER. GE. 102) THEN 

READ ( IGTFUNIT , * ) NHE7UDER 

DO I=1,NHEADER 

READdGTFUNIT, *). 

ENDDO 
ENDIF 



Now begin real read- in. 
DO 5 1=1, NGTF 

READdGTFUNIT, *,END=6) R(I),GTF{I) 
CONTINUE 
CONTINUE 
IGTF=I-1 
CLOSE (15) 

RETURN 
END 



SUBROUTINE 



L(^^EP_QSTATES 



Loads Solar Energetic Particle Ionic Charge State Distribution 
from datafile into COMMON/SEP_QSTATES 

11-17-97: IMPLICIT NOKE and variable- type declarations added. 

IMPLICIT NONE 
REAL*4 SEP_QSTATES 

COMMON/SEP_QSTATES/SE?_QSTATES (30, 30) 

INTEGER*4 ISQUNIT 

DATA ISQUNIT/18/ 

LOGICAL IEXIST,CREME96_INQUIRE 

INTEGER*4 STAT, CREME96 OPEN 



INTEGER*4 J, NLINES , ILINE, KMIN, KMAX, IDUM, K 

First see if QSTATES file is available here: 

INQUIRE (FILE= ' CREME96 : QSTATE. DAT' , EXIST=IEXIST) 
iexist = creme96_inquire ('qstate.dat' , 'cr96 tables ' ) 
IF ( .NOT. IEXIST) THEN 
WRITE(6,999) 

FORMAT {' File CREME96: QSTATE. DAT not found. Abort.') 
STOP 

ELSE 

OPEN {UNIT= ISQUNIT, READONLY, SHARED, STATUS = ' OLD' , 
& FILE= ' CREME96 : QSTATE . DAT' ) 

Stat = creme96_open ('qstate.dat' , 'cr96tables' , isqunit, 'old' ) 

DO 500 J=:l,30 

NLINES= (J-l)/8+l 

DO 400 ILINE=1,NLINES 

KMIN=(ILINE-1)*8+1 

KMAX=ILINE*8 

IF (KMAX.GT. J)KMAX=J 

READ (ISQUNIT, 9006) IDUM, (SEP_QSTATES (J, K) , K=KMIN, KMAX) 
FORMAT (13, 8F8. 5) 
CONTINUE 
CONTINUE 
CLOSE (ISQUNIT) 
ENDIF 



RETURN 
END 



SUBROUTINE LOALJ 



PED PROTONS (TRAPDFILE) 




C 

c 



ru 

: : 

ru 

Ly 

110 



999 



C 
C 



100 

C 

C 



Subroutine to unload CREME96 trapped proton spectrum from specified 
file into a common bloc, for later combination with non- trapped fluxes. 



Last update: 18 November 1997 



IMPLICIT NONE 

CHARACTER* 80 TRAPDFILE , ILINE 

INTEGER*4 MAXSPEC, N, NZ , NZT, i , ITRPSPEC 
INTEGER* 4 I VER , NHEADER , STAT, CREME96_OPEN, ILONG 
REAL*4 ENTRP,FLUXTRP,EL,EU 
PARAMETER {MAXSPEC=5000 ) 

COMMON/TRPDAT/ITRPSPEC, ENTRP (MAXSPEC) , FLUXTRP (MAXSPEC) 

CALL CHECK_CREME96_VERS ION (TRAPDFILE, IVER) 

Stat = creme96_open (TRAPDFILE, 'user' ,10, 'old' ) 
ILONG=INDEX (TRAPDFILE, ' . ' ) 

IF (TRAPDFILE (ILONG+1 : ILONG+2) .EQ. 'TR' .or. 
TRAPDFILE ( ILONG+1 : ILONG+3 ) . EQ . ' tr ' ) THEN 

•IF ( IVER. GE. 102) THEN 
READ (10,*) NHEADER 
DO i=l, NHEADER 

READ{10,110) ILINE 

FORMAT (ABO) 
ENDDO 
ENDIF 

read (10, *) el, eu,n,nz,nzt 
IF (NZ.NE.l) THEN 
WRITE{6,999) 

FORMAT (Ix,' WARNING: No proton spectrum in input file:', 
/,lx,' STOP in LOAD_TRAPPED_PROT0NS ' ) 

STOP 
ENDIF 

Calculate abscissae (energy values) 

ENTRP (1) =el 
ENTRP (N) =eu 
do 100 i=2,N-l 

ENTRP (i) =el* (eu/el) ** (float (i-1) /float (n-1) ) 
continue 

Read blank line 



Written by: 



Allan J. Tylka 
Code 76 54 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka@crs2 .nrl .navy.mil 



readdO, ILINE 
:: read in the flux 

IF (N.GT.MAXSPEC) N=MAXSPEC 
read (10,*) {fluxtrp(i) ,i=l,n) 
CLOSE (10) 

2 Eliminate end-of-file zeroes from returned spectrum: 

ITRPSPEC=0 
DO 1000 1=1, N 

IF (FLUXTRP(I) .GT.0.0) ITRPSPEC=I 
1000 CONTINUE 

ELSE 

WRITE (6, 9999) TRAPDFILE 
9999 FORMATdx,' Specified TRAPPED PROTON FILE = 

& /,lx,A80, 

& /,lx,' does not appear to be a CREME96 -generated file.', 

& /,lx,' STOP') 

ENDIF 

RETURN 



a 

s y end 



f=3 i 

w 



REAL*4 FUNCTIOl^^NETIC_RIGIDITY(EK,Q,A) 

Function to calculate the magnetic rigidity (in GV/c) 
given inputs: 

EK = kinetic energy per nucleon in MeV/amu 

Q = charge 

A = mass number (> 0 for ions; 0 for electrons) 




IMPLICIT REAL*8 (D) 
REAL*4 EK,Q,A 
DATA DAMU/0. 9315016D0/ 
DATA DELEC/0. 00051099906/ 

DK=EK/1000.D0 

DA=A 

DQ=Q 

DR= gamma*beta 

IF (DA.GT.0.0) THEN 
Ion case : 

DR= (l.DO+DK/DAMU) **2-l.D0 
DR=DSQRT (DR) *DA/DQ*DAMU 

ELSEIF (DA.EQ.O) THEN 

Electron case: 

DR= (1 .DO+DK/DELEC) **2-l .DO 

DR=DSQRT (DR) *DELEC 

ENDIF 



MAGNETIC_RIGIDITy=DR 

RETURN 
END 



c 



program MAKE_^^p_TABLE 

C 

C Makes two-column energy vs. dE/dx tables from CREME96 software. 



IMPLICIT NONE 

INTEGER*4 NBINMAX , STAT, CREME96_OPEN 
PARAMETER (NBINMAX=5000) 
INTEGER*4 NBINS , K, IZ , OUTUNIT, IMAT 
REAL*4 E (NBINMAX) 

REAL* 4 EMIN , EMAX , EN , DE , 2 , AN , DEDX , STPOW 

CHARACTER* 80 OUTFILE 

CHARACTER*12 MATERIAL, MATS (2 ) 

DATA MATS/ 'ALUMINUM ' , ' SILICON ' / 

DATA OUTUNIT/8/ 

INTEGER*4 I ERR, I ACCEPT 

DATA IERR/0/ 



nl 



n! 



if; 



MATERIAL= ' ALUMINUM 
WRITE (6, 8000) 

8000 FORMAT {' This program will make a table of stopping power', 
& ' in aluminum for the specified' 

& /,' nuclei. The table will be specified for NBINS' , 

& ' logarithmically-spaced energy' , 

& /,' values between limits EMIN and EMAX (in MeV/nuc) ' ) 

8101 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 8001) NBINMAX 

8001 FORMATC Enter EMIN, EMAX (in MeV/nuc) and NBINS (<',I5,')') 
READ (*, *,ERR=8 101, IOSTAT=IERR) EMIN, EMAX , NBINS 

IF (NBINS. GT. NBINMAX) NBINS^NBINMAX 
WRITE (6, 8002) EMIN, EMAX , NBINS 

8002 FORMAT dx,' EMIN = ',E13.5,' EMAX = ',E13.5,' NBINS = ',15) 

8103 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE{6,8003) 

8003 FORMATC Select material: Enter 1 for Aluminum; 2 for Silicon') 
READ(*, *,ERR=8103, IOSTAT=IERR) IMAT 

MATERIAL=MATS ( IMAT) 
WRITE (6, 8004) MATERIAL 

8004 FORMATdx,' Material = ',A12) 



C 
C 



Compute energies on logaritmically- spaced grid 



DE= (EMAX/EMIN) ** (1 . / (NBINS- 1 . ) ) 

E(1)=EMIN 

DO K=2, NBINS- 1 

E(K) =E(K-1) *DE 
END DO 

E (NBINS) =EMAX 

9102 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE (6, 9002) 
9002 FORMATdx,' Enter name of output file:') 

READ(*,2,ERR=9102, IOSTAT=IERR) OUTFILE 
2 FORMAT (A80) 

CALL CHECK_OUTPUT_FILE (OUTFILE, lACCEPT) 

IF (lACCEPT.NE.O) THEN 

WRITE (6, 1011) OUTFILE (1:75) 



WRITE (6, 1012) 

1011 FORMATdx,' Previous try at OUTPUT name = ',/,5x,A75) 

1012 FORMATdx,' Try again. ' ) 
GOTO 9102 

ENDIF 

: open (unit=OUTUNIT,status = ' new ,file='USER: ' //OUTFILE) 

Stat = creme96_open (out file, 'user' , outunit, 'new' ) 
WRITE (OUTUNIT, 191) EMIN, EMAX , NBINS 

191 FORMAT (ix, '%EMIN = ',E13.5,' EMAX = ',E13.5,' NBINS = ',15) 



114 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9003) 

9003 FORMATdx,' Enter first desired IZ,A values for table: ' 
& /,8x,' IZ = atomic number', 

& /,8x,' A = mass number') 

READ(*, *,ERR=114, IOSTAT=IERR) 12, AN 



115 CONTINUE 
Z=IZ*1.0 

IF (IZ.LT.O .or. IZ.GT.92) THEN 
WRITE (6, 9004) IZ 

9004 FORMATdx,' Invalid atomic number: ',16,' Please try again.') 
GOTO 114 
ENDIF 



WRITE (OUTUNIT, 190) IZ, AN, MATERIAL 
190 FORMATdx, ' %Energy (MeV/nuc) ' 
& ' dE/dx (MeV/ (g/cm2) ) ' , 

& ' for Z = ',12,' A = ',F6.2,' in ' ,A12) 



DO 80 K=l, NBINS 
EN=E{K) 

DEDX=STPOW (EN, Z, AN, MATERIAL) 
C STPOW . calculates energy loss in MeV/nuc ; 

DEDX=AN*DEDX 

write (OUTUNIT, 34) EN,DEDX 
34 FORMAT (2X, E12 . 5', 2X, E12 . 5) 

80 continue 



9106 CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE(6, 9006) 

9006 FORMATdx,' Enter next IZ,A value (0 0 to end program):') 
READ ( * , * , ERR= 9106, IOSTAT= lERR ) I Z , AN 
IF (IZ.GT.O) GOTO 115 
CLOSE (OUTUNIT) 
STOP 
end 



SUBROUTINE MAKE 



:t_spectrum(letmin, letmax, lin 




:t,difspec) 



Makes SIMPLE (ie., needs work) numerical differentiation of 
integral LET spectrum to produce a differential LET spectrum. 

IMPLICIT NONE 
REAL*4 LETMIN,LETMAX 
INTEGER*4 LIN,L,K,LARR 
REAL*4 SPECT,DIFSPEC 
DIMENSION SPECT(l) ,DIFSPEC(1) 
REAL* 8 DY,DL,LETG 
PARAMETER { LARR= 1 0 0 2 ) 
DIMENSION LETG(LARR) 

Fill array of LET values: 
L=LIN 

IF (L.GT.LARR) L=LARR 

DL= (LETMAX/LETMIN) ** { 1 . /FLOAT (L- 1 ) ) 
LETG(l) =LETMIN 
DIFSPEC(l) =0.0 
DO 400 K=2,L-1 

LETG(K) =LETG{K-1) *DL 

DIFSPEC(K) =0.0 
CONTINXJTE 
LETG(L) =LETMAX 
DIFSPEC(L)=0.0 

Now calculate differential LET spectrum. 

DL=LETG(2) -LETG(l) 
IF (SPECT(2) .GT.O. ) 
& DIFSPEC(l) =-SPECT(l) *ALOG (SPECT (2 ) /SPECT(l) ) /DL 
DO 500 K=2,L-1 

IF {SPECT(K+1) .GT.0.0) THEN 
DL= (LETG(K+1) -LETG(K-l) ) 
DY=-ALOG (SPECT (K+l) /SPECT (K-1) ) 

ELSE 

IF {SPECT(K) .GT.0.0) THEN 
DL=LETG{K) -LETG{K-1) 
Dy=-ALOG (SPECT (K) /SPECT (K-1) ) 
ENDIF 
ENDIF 

DIFSPEC (K) =SPECT (K) *DY/DL 
CONTINUE 



RETURN 
END 



program MAKE 




Rewrites flux output file from CREME96/UPROP format 
into a .FIG file. 

IMPLICIT NONE 

INTEGER*4 MARR, NELM, STAT, CREME96_OPEN 
PARAMETER (MARR=5000 , NELM=92 ) 
REAL*4 FLUX{NELM,MARR) ,E(MARR) 
REAL*4 EL,EU,ETEMP,EMINCUT,EMAXCUT 

INTEGER*4 lACCEPT, IFILETYPE, IZMIN, IZMAX,M, IZLO, IZUP 

CHARACTER*80 INFILE , OUTFILE 

CHARACTER*80 ILINE , TEMPLINE 

INTEGER*4 IZTARG, NHMAX, LINEMAX , ICOUNT 

PARAMETER {NHMAX=30) 

DIMENSION ILINE(NHMAX) 

INTEGER* 4 I , OUTUNIT , FHDUNIT, NHEADER, IZDUM, ILONG 
LOGICAL ZERO 
INTEGER*4 lERR 
DATA IERR/0/ 

OUTUNIT=42 
FHDUNIT=43 
CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6, 9001) 

FORMATdx,' Enter name of input file', 

' (something. FLX, .TFX, or .TR*):') 
READ{*, 2,ERR=112, IOSTAT=IERR) INFILE 
FORMAT (AS 0) 
IFILETYPE=3 
WRITE (6, 1020) INFILE 

FORMAT (' Input Flux File =',/,lx,A80} 
CALL CHECK_FILE (IFILETYPE, INFILE, lACCEPT) 
IF (lACCEPT.NE.O) GOTO 112 

Now unload fluxes from this file: 

EMINCUT=0.0 

EMAXCUT=1.0E+24 

CALL UNLOAD_PARTIAL_FLUX (INFILE, IZMIN, IZMAX , EMINCUT, EMAXCUT, 

EL,EU,M,IZLO,IZUP, 
FLUX) 

Calculate abscissae (energies) 

e (1) =EL 
e (M) =EU 
do 10 i=2,M-l 

e (i) =el* (eu/el) ** (float (i-1) /float (M-l) ) 
continue 

Now start to copy information to new file: 
CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9002) 

FORMATdx,' Enter name of output file (something. FIG) :' ) 

READ ( * , 2 , ERR=9102 , IOSTAT=IERR) OUTFILE 
CALL CHECK_OUTPUT_FILE (OUTFILE, lACCEPT) 



.1^^ THEN 
0)^^FILE{1:75) 



IF (I ACCEPT. 
WRITE(6,1010) 
WRITE(6, 1011) OUTFILE(l:75) 
WRITE (6, 1012) 

1010 FORMATdx,' INPUT file = ',/,5x,A75) 

1011 FORMATdx,' Previous try at OUTPUT name = ',/,5x,A75) 

1012 FORMATdx,' Try again.') 
GOTO 9102 

ENDIF 

c open(unit=OUTUNIT, status='new' , f ile='USER: ' //OUTFILE) 

Stat = creme96_open (out file, ' user' , outunit, 'new' ) 
VfRITE (OUTUNIT, 185) INFILE (1 : 70) 
185 FORMATC *' ,A50) 

C 

C Now add FIGGEN header information: 

C Write FIGGEN header 

c OPEN (UNIT=FHDUNIT,status=' old' , readonly , shared, 

c & file='CREME96 :FLX_FIG. header' ) 

Stat = creme96_open{ 'flx_fig. header' , 'cr96 tables ' ,fhdunit, 'old' ) 
6 CONTINUE 

READ (FHDUNIT,2,END=8) ILINE(l) 

WRITE (OUTUNIT, 2) ILINE (1) 
^ GOTO 6 

O 8 CONTINUE 

CLOSE (FHDUNIT) 

; i 

U ILONG=LEN( INFILE) 

ry CALL CAPITALIZE_STRING (INFILE, ILONG) 

UJ WRITE (OUTUNIT, 186) INFILE (1:50) 

|i 186 FORMAT (' ST 0.3 100 1 . OE+5 0.//""',A50) 

2 C Transfer header information from input file 

U CALL UNLOAD_HEADERS (INFILE, NHMAX, ILINE, LINEMAX) 

hi IF (LINEMAX. GT.O) THEN 

y DO 100 1=1, LINEMAX 

2 TEMPLINE=ILINE(I) 

TEMPLINE=' *' / /TEMPLINE (2:80) 

WRITE (OUTUNIT, 2 ) TEMPLINE 
'"^ 100 CONTINUE 
ENDIF 

114 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9003) 

9003 FORMAT dx,' Enter desired IZMIN,IZMAX for FIGure : ') 
READ(*, *,ERR=114, IOSTAT=IERR) IZMIN, I2MAX 

115 CONTINUE 

DO 200 IZTARG=I2MIN, IZMAX 

IF (IZTARG.LT.O .or. IZTARG . GT . 92 ) THEN 
WRITE (6, 9004) IZTARG 

9004 FORMATdx,' Invalid atomic number: ',16) 
GOTO 200 

ENDIF 

C 

C Does this file contain the Z value of interest? 



IF ( IZTARG. LT.I2L0 .or. IZTARG.GT. IZUP) THEN 
WRITE (6, 9005) I ZLO, IZUP, IZTARG 



9005 FORMAT ( Ix, '^^t his file: IZLO = ',15,' I 

& /,lx,'^Z= M5,' not found here .' ) 

GOTO 200 
ENDIF 



WRITE (OUTUNIT, 30) IZTARG 
30 FORMATC * IZ = ' , 13) 

C 

ZERO= . TRUE . 
DO 50 1=1, M 

IF (FLUXdZTARCD .GT.O.) THEN 
ZERO= . FALSE . 
GOTO 55 
ENDIF 

50 CONTINUE 
55 CONTINUE 



IF ( .NOT. ZERO) THEN 
IF (MOD (IZTARG, 2) .EQ.O) THEN 
WRITE (42, 31) M 

ELSE 

WRITE (42, 32) M 

ENDIF 

31 FORMAT (' FRENCH ',14,' 0.01 0') 

□ 32 FORMAT (' FRENCH ',14,' 0.10 2') 

□ DO 80 1=1, M 

Q IF (FLUXdZTARG,!) .GT.0.0) THEN 

nj write (OUTUNIT, 34) e (i) , flux ( IZTARG, i ) 

ENDIF 

34 FORMAT(2X,E12.5,2X,E12.5) 
£7 80 continue 

ICOUNT=ICOUNT+1 

IF {IC0UNT.GT.3) IC0UNT=1 

ETEMP=E (M) * (1 . +ICOUNT*0 . 05) 
^ WRITE (OUTUNIT, 90) ETEMP , FLUX { I ZTARG , M ) , IZTARG 

H 90 FORMATCSTHC -0.2 ' , E12 . 5 , 2x, E12 . 5 , ' 0//',I2) 

SI ENDIF 

200 CONTINUE 



CLOSE (OUTUNIT) 

STOP 

end 



c 

c 
C 
c 



program ^4AKE 



m- 



TABLE 



Rewrites flux output file from CREME96/UPROP format 
into a two column table. 

IMPLICIT NONE 

INTEGER*4 MARR, NELM, STAT, CREME96_OPEN 
PARAMETER (MARR=5000 , NELM=92 ) 
REAL*4 FLUX (NELM, MARR) , E (MARR) 
REAL*4 EL,EU,EMINCUT,EMAXCUT 

INTEGER*4 lACCEPT, IFILETYPE, IZTARG,M, IZLO, IZUP 
CHARACTER* 80 INFILE , OUTFILE 
INTEGER*4 I , OUTUNIT, NHEADER, I2DUM 
INTEGER*4 lERR 
DATA IERR/0/ 



112 



9001 



%0 



□ 1020 



C 
C 



* 



10 



OUTUNIT=42 
CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9001) 

FORMAT (Ix,' Enter name of input file', 

' (something. FLX, .TFX, or .TR*):') 
READ (* , 2 , ERR=112 , IOSTAT=IERR) INFILE 
FORMAT (A80) 
IFILETYPE=3 
WRITE (6,1020) INFILE 

FORMATC Input Flux File =',/,lx,A80) 
CALL CHECK_FILE ( IFILETYPE , INFILE , lACCEPT) 
IF ( lACCEPT. NE.O) GOTO 112 

Now unload fluxes from this file: 

IZDUM=0 

EMINCUT=0.0 

EMAXCUT=1.0E+24 

CALL UNLOAD_PARTIAL_FLUX ( INFILE , I ZDUM , I ZDUM , EMINCUT , EMJ^CLT , 

EL,EU,M,IZLO,IZUP, 
FLUX) 

Calculate abscissae (energies) 

e(l)=EL 
e (M) =EU 
do 10 i=2,M-l 

e (i) =el* (eu/el) ** (float (i-1) /float (M-l) ) 
continue 



Now start to copy information to new file: 



9102 



9002 



1010 
1011 



CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9002) 

FORMATdx,' Enter name of output file (something.DAT):') 

READ(*, 2,ERR=9102, IOSTAT=IERR) OUTFILE 

CALL CHECK_OUTPUT_FILE (OUTFILE, lACCEPT) 

IF (I ACCEPT. NE.O) THEN 

WRITE (6, 1010) INFILE (1:75) 

WRITE (6, 1011) OUTFILE (1:75) 

WRITE (6, 1012) 

FORMATdx,' INPUT file = ',/,5x,A75) 

FORMATdx,' Previous try at OUTPUT name = ',/,5x,A75) 



1012 



FORMATdx,' Ti^p^ain.') 

GOTO 9102 
ENDIF 



; open (unit=OUTUNIT,status=' new' , file='USER: ' //OUTFILE) 

Stat = creme96_open(outfile, 'user' ,outiinit, 'new ) 
WRITE (OUTUNIT, 185) INFILE(1:79) 
185 FORMAT (lx,A7 9) 

CALL CHECK_HEADER_LENGTH ( INFILE , NHEADER ) 
CALL COPY_HEADERS ( INFILE, NHEADER , OUTUNIT) 

CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE (6, 9003) 

FORMATdx,' Enter desired IZ value for table: ') 
READ ( * , * , ERR=114 , IOSTAT=IERR) IZTARG 
CONTINUE 

IF ( IZTARG. LT.O .or. IZTARG . GT . 92 ) THEN 
WRITE (6, 9004) IZTARG 

FORMATdx,' Invalid atomic number: ',16,' Please try again.') 
GOTO 114 
ENDIF 

Does this file contain the 2 value of interest? 

IF (I2TARG.lt. I ZLO .or. IZTARG . GT . I ZUP) THEN 
WRITE (6, 9005) I ZLO, I ZUP , IZTARG 

FORMATdx,' In this file: IZLO = ',15,' I2HI =',I5, 
/,lx,' IZ = ',15,' not found here.', 
/,lx,' Please try again.') 
GOTO 114 
ENDIF 

WRITE (OUTUNIT, 190) IZTARG 
FORMATdx, ' %Energy (in MeV/nuc) ' 

' vs. Flux (in particles/m2-s-sr-MeV/nuc) ' , 
' for Z = ' ,12) 

DO 80 1=1, M 

IF (FLUX (IZTARG, I) .GT. 0.0) THEN 

write (OUTUNIT, 34) e ( i) , flux (IZTARG, i ) 
ENDIF 

FORMAT (2X, E12 . 5 , 2X, E12 .5) 
continue 

9106 CONTINUE 

CALL RETRY_INPUTdERR) 
WRITE (6, 9006) 

9006 FORMATdx,' Enter next Z value (0 to end program):') 
READ ( * , * , ERR=9106 , IOSTAT=IERR) IZTARG 
IF { IZTARG. GT.O) GOTO 115 

CLOSE (OUTUNIT) 

STOP 

end 



114 

9003 
115 

9004 

C 



9005 



Sc 
Sc 



190 



Sc 
Sc 



34 
80 



c 



program MAKE_ 

c 

c Rewrites integral LET spectrum output file from CREME96/UPR0P format 

C to a FIGGEN file 



IMPLICIT NONE 

INTEGER*4 MARR, STAT, CREME96_OPEN 
PARAMETER (MARR=5000) 
REAL*4 FLUX (MARR) , E (MARR) 
INTEGER* 4 lACCEPT, IFILETYPE, M 
CHARACTER* 80 INPILE , OUTFILE , HEADER 
CHARACTER*80 ILINE, TEMPLINE 
INTEGER* 4 NHMAX , LINEMAX 
PARAMETER (NHMAX=30) 
DIMENSION ILINE (NHMAX) 

INTEGER*4 I , OUTUNIT, FHDUNIT, lERR, ISPECTYPE, ILONG 

DATA IERR/0/ 

LOGICAL INTLET,DIFLET 



OUTUNIT=42 
FHDUNIT=43 
ILONG=0 

112 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE(6, 9001) 
9001 FORMATdx,' Enter name of input file: 

& /, 5x, ' (some thing. LET for an integral LET spectrum;', 

& /,5x,' something . DLT for a differential LET spectrum)') 

READ (* , 2 , ERR=112 , IOSTAT=IERR) INFILE 
2 FORMAT (A80) 

INTLET= . FALSE . 

DIFLET=:. FALSE. 

ILONG= INDEX (INFILE, ' . ' ) 

IF (ILONG. EQ.O) GOTO 112 

IF (INFILE (IL0NG+1:IL0NG+ 3) .EQ.'LET' .or. 
& INFILE {IL0NG+l:IL0NG+3) .EQ.'let') INTLET= . TRUE . 

IF ( INFILE (IL0NG+l:IL0NG+3) .EQ.'DLT' .or. 
& INFILE (ILONG+1 :IL0NG+3) .EQ. 'dlt' ) DIFLET= . TRUE . 

IF (.NOT.INTLET .and. .NOT.DIFLET) THEN 
111 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9000) 

9000 FORMATdx,' LET file type not known. Please specify type:', 
& /,lx, ' 0=integral or l=dif f erential ' ) 

READ (2 , * , ERR=111 , IOSTAT=IERR) ISPECTYPE 
IF (ISPECTYPE.lt. 0 .or. ISPECTYPE . GT . 1) GOTO 111 
IF (ISPECTYPE. EQ.O) INTLET= . TRUE . 
IF ( ISPECTYPE. EQ.l) DIFLET= . TRUE . 
ENDIF 



IF (INTLET) IFILETYPE=5 
IF (DIFLET) IFILETYPE=6 
WRITE (6, 1020) INFILE 
■1020 FORMATC Input Flux File =',/,lx,A80) 

CALL CHECK_FILE ( IFILETYPE , INFILE , lACCEPT) 
IF ( I ACCEPT. NE.O) GOTO 112 



C 



Now unload fluxes from this file : 



CALL UNLOAD_L^^fPECTRUM ( INFILE , E , FLUX , M) 
Now start to copy information to new file: 
CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE (6, 9002) 

FORMATdx,' Enter name of output file (something . FIG) :' ) 
READ(*, 2,ERR=9102, IOSTAT=IERR) OUTFILE 

CALL CHECK_OUTPUT_FILE (OUTFILE, lACCEPT) 
IF (lACCEPT.NE.O) THEN 
WRITE (6, 1010) INFILE (1:75) 
WRITE (6, 1011) OUTFILE (1:75) 
WRITE (6, 1012) 

FORMATdx,' INPUT file = ',/,5x,A75) 

FORMATdx,' Previous try at OUTPUT name = ',/,5x,A75) 
FORMATdx, ' Try again. ' ) 
GOTO 9102 
ENDIF 

open (unit=OUTUNIT,status=' new' , file='USER: ' //OUTFILE) 
Stat = creme96_open(outfile, 'user' ,outunit, 'new' ) 
WRITE (OUTUNIT, 185) INFILE (1 : 70) 
FORMATC*' ,A50) 




Now add FIGGEN header information: 

Write FIGGEN header 
IF (INTLET) HEADER=' CREME96 : LETSPEC_FIG . header ' 
IF (DIFLET) HEADER=' CREME96 :DLTSPEC_FIG. header' 

IF ( INTLET) HEADER= ' LETSPEC_FIG . header ' 

IF (DIFLET) HEADER= ' DLTSPEC_FIG . header ' 
OPEN (UNIT=FHDUNIT , status= ' old' , readonly, shared, f ile=HEADER) 

Stat = creme96_open (header ,' cr 96 tables' , fhdunit, ' old' ) 

CONTINUE 

READ {FHDUNIT,2,END=8) ILINE(l) 
WRITE (OUTUNIT, 2) ILINEd) 
GOTO 6 
CONTINUE 
CLOSE (FHDUNIT) 

ILONG=LEN( INFILE) 

CALL CAPITALIZE_STRING (INFILE, ILONG) 

IF (INTLET) WRITE (OUTUNIT, 186) INFILE (1:50) 
IF (DIFLET) WRITE (OUTUNIT, 187) INFILE (1:50) 
FORMATC ST 0.3 1 . OE+2 1 . OE+3 0.//^^',A50) 
FORMATCST 0.3 1 . OE+3 1 . OE+3 0.//^^',A50) 
Transfer header information from input file 
CALL UNLOAD_HEADERS (INFILE, NHMAX, ILINE,LINEMAX) 
IF (LINEMAX.GT.O) THEN 
DO 100 I=1,LINEMAX 

TEMPLINE=ILINE (I) 

TEMPLINE=' *' //TEMPLINE(2 :80) 

WRITE (OUTUNIT , 2 ) TEMPLINE 
CONTINUE 
ENDIF 



IF (INTLET) WRITE (OUTUNIT, 190) 



IF (DIFLET) WT^^OUTUNIT, 191) 

190 FORMAT (Ix, '*%L^r( in MeV-cm2/g) ' 
& 'vs. Integral Flxix (in particles/tn2-s-sr) ' ) 

191 FORMAT (IX, ' ♦%LET (in MeV-cm2/g) ' 

& ' vs. Differential Flux (in particles/m2-s-sr- (MeV-cm2/g) ) ' ) 

C 

WRITE(42,31) M 
31 FORMAT (' FRENCH ',14,' 0.01 0') 



DO 80 1=1, M 

IF (FLUX(I) .GT.0.0) THEN 

write (OUTUNIT, 34) e{i) ,flux(i) 
ENDIF 

34 FORMAT(2X,E12 .5,2X,E12.5) 

80 continue 



CLOSE (OUTUNIT) 

STOP 

end 



program MAK^^p^:SPEC_TABL£ 

Rewrites integral LET output file from CREME96/UPROP format 
into a two column table. 



IMPLICIT NONE 

INTEGER*4 MARR, STAT, CREME96_OPEN 
PARAMETER (MARR=5000) 
REAL*4 FLUX(MARR) ,E(MARR) ,LETMIN 
INTEGER*4 lACCEPT, IFILETYPE, M 
CHARACTER*80 INFILE, OUTFILE 

INTEGER*4 I , OUTUNIT, NHEADER , lERR, ISPECTYPE, ILONG 

DATA IERR/0/ 

LOGICAL INTLET,DIFLET 



OUTUNIT=42 

ILONG=0 

CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9001) 

FORMATdx,' Enter name of input file: 

/, 5x, ' (something. LET for an integral LET spectrum;', 
/,5x,' something. DLT for a differential LET spectrum)') 

READ{*,2,ERR=112, IOSTAT=IERR) INFILE 

FORMAT (A80) 

INTLET= . FALSE . 

DIFLET=.FALSE. 

ILONG=INDEX( INFILE, ' . ' ) 

IF (ILONG. EQ.O) GOTO 112 

IF (INFILE (ILONG+1 : ILONG+3) .EQ. 'LET' .or. 

INFILE (IL0NG+l:IL0NG+3) .EQ.'let') INTLET= . TRUE . 
IF (INFILE (ILONG+1: ILONG+3) .EQ.'DLT' .or. 

INFILE { ILONG+1: ILONG+3) .EQ.'dlt') DIFLET= . TRUE . 

IF { . NOT . INTLET . and . . NOT . D I FLET ) THEN 
CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6,9000) 

FORMATdx,' LET file type not known. Please specify type:', 

/,lx,' 0=integral or l=dif f erential ' ) 
READ (2 , * , ERR=111 , IOSTAT=IERR) ISPECTYPE 
IF (ISPECTYPE.lt. 0 .or. ISPECTYPE . GT . 1) GOTO 111 
IF (ISPECTYPE. EQ.O) INTLET= . TRUE . 
IF ( ISPECTYPE. EQ.l) DIFLET= . TRUE . 
ENDIF 

•IF (INTLET) IFILETYPE=5 
IF (DIFLET) IFILETYPE=6 
WRITE (6, 1020) INFILE 

FORMAT (' Input Flux File =',/,lx,A80) 
C7VLL CHECK_FILE (I FILETYPE, INFILE, I ACCEPT) 
IF (lACCEPT.NE. 0) GOTO 112 



Now unload fluxes from this file: 

CALL UNLOAD_LET_SPECTRUM ( INFILE , E , FLUX , M) 

Now start to copy information to new file: 



CONTINUE 

CALL RETRY INPUT (I ERR) 



WRITE (6, 9101) 

9101 FORMATdx,' Enter starting LET value (in MeV-cm2/g) ' , 
& ' to be included in output table.', 

& /,' (For most SEU applications, LET = 100 MeV-cm2/g' 

& ' is appropriate.)') 

READ(*,*,ERR=9201, IOSTAT=IERR) LETMIN 

9202 CONTINUE 

CALL RETRY_INPUT (lERR) 
WRITE(6, 9002) 

9002 FORMATdx,' Enter name of output file (something.DAT):') 
READ (* , 2 , ERR=92 02 , IOSTAT=IERR) OUTFILE 
CALL CHECK_OUTPUT_FILE (OUTFILE , lACCEPT) 
IF (lACCEPT.NE. 0) THEN 
WRITE (6, 1010) INFILE (1 : 75) 
WRITE (6, 1011) OUTFILE (1:75) 
WRITE (6, 1012) 

1010 FORMATdx,' INPUT file = ',/,5x,A75) 

1011 FORMATdx,' Previous try at OUTPUT name = ',/,5x,A75) 

1012 FORMATdx,' Try again.') 
GOTO 9202 

ENDIF 

c open(unit=OUTUNIT, status='new' , f ile='USER: ' //OUTFILE) 

Stat = creme96_open (outfile, ' user ', outunit, ' new' ) 
WRITE (OUTUNIT, 185) INFILE (1 : 50) , LETMIN 
185 FORMAT (lx,A50, ' LET > ',E12.5) 

CALL CHECK_HEADER_LENGTH( INFILE, NHEADER) 
CALL COPY_HEADERS ( INFILE , NHEADER, OUTUNIT) 

IF (INTLET) WRITE (OUTUNIT, 190) LETMIN 
IF (DIFLET) WRITE (OUTUNIT, 191) LETMIN 

190 FORMATdx, ' %LET (in MeV-cm2/g) ' 

& ' vs. Integral Flux (in particles/m2 -s-sr) ; ' , 

& ' LET >' ,E10.3) 

191 FORMATdx, ' %LET (in MeV-cm2/g) ' 

& 'vs. Diff. Flux (in #/m2 -s-sr- (MeV-cm2/g) ) ; ' , 
& ' LET >' ,E10.3) 



DO 80 1=1, M 

IF (FLUX (I) .GT.O.O.and.E(I) .GE. LETMIN) THEN 

write (OUTUNIT, 34) e{i) ,flux(i) 
ENDIF 

34 FORMAT (2X, E12 . 5 , 2X, E12 .5) 

80 continue 



CLOSE (OUTUNIT) 

STOP 

end 



SUBROUTINE MF 



E^^IRGY, IZ , lA, NAME , MEAN_FREE_PATi^^ 



This subroutine computes the mean free path of any nuclide 
{IZ,IA) in material NAME at energy ENERGY (MeV/N) . 



It must be linked with CREME96 : ZTARGET.DAT 



INCLUDE ' CREME 9 6 : ZCOMMON . CMN ' 
CHARACTER* 12 NAME 

REAL NA(28) , IADJ(28) ,NASPM(28) , DENS , E TAD 
INTEGER NZ { 2 8 ) , IGAS , NAS 
COMMON /TBLOCK/DENS , ETAD , IGAS , NAS , 
& NZ,NA, IADJ,NASPM, 

& NTOTAL , AVGZ , AVGZ2 , AVGA, AVGI 

REAL IA,MEAN_FREE_PATH 

DATA AVOGADRO/6.022045E23/ ! particles/mole 



CALL ZTARGET{NAME) 



Compute mulitiplicative factor 

FACT=1 . E27*AVGA/AVOGADRO 

AVGS=0. 

DO J=1,NAS 

NNZ=NZ(J) 

AAN=NA(J) 

CALL SMASH{IZ,IA,NNZ,AAN, ENERGY, S) 
AVGS=AVGS+NASPM (J) *S 
END DO 

AVGS =AVGS /NTOTAL 
MEAN_FREE_PATH= AVGS / FACT 

RETURN 
END 

SUBROUTINE SMASH ( IZ , lA, JZ , JA, E , CROSS_SECTION) 



C Computes nucleus -nucleus total reaction cross section 
C 

C inputs : 
C 

C E = projectile energy (MeV/nucleon) 

C IZ = projectile charge 

C lA = projectile mass 

C JZ = target charge 

C JA = target mass 

C 

C SUBROUTINE 

C SUBROUTINE LETAW ( IZ , A, ENERGY, CROSS_SECTION) 

C SUBROUTINE OVERLAP { lA, JA, CROSS_SECTION) 

C 

REAL IA,JA 

C Define constants 



PI=3 . 1415927 

Zero cross section at zero energy 



IF (E.LE.O) THEN 
CROSS_SECTION=0 
RETURN 

ENDIF 



C proton-proton reactions 

IF (IZ*IA*JZ*JA.LE.1.02) THEN 
IF (IZ.EQ.JZ) THEN 

CROSS_SECTION=PTOTAL (E, 1) 
ELSE 

CROSS_SECTION=PTOTAL (E, 2) 
ENDIF 
RETURN 
ENDIF 



C proton or neutron projectile 

IF (IZ*IA.LE.1.02) THEN 

CALL LETAW ( JZ , JA, E , CROSS_SECTION) 

RETURN 
ENDIF 



^ C proton or neutron target 

^ IF (JZ*JA\LE.1.02) THEN 

O CALL LETAWdZ, IA,E,CROSS_SECTION) 

Q RETURN 

fy ENDIF 

C general nucleus -nucleus collision 

Ms 

, CALL OVERLAP (IA,JA,CROSS_SECTION) 

R I RETURN 
iH END 

\^ C FUNCTION OVERLAP (IA,JA,CROSS_SECTION) 

'7; subroutine OVERLAP (lA, JA, CROSS_SECTION) 

'"'^ ! Westfall mass-changing 10*pi*r**2=67 . 887 

REAL IA,JA 

CROSS_SECTION=67 . 887* (lA** (1 . /3 . ) +JA** (1 . /3 . ) -1 . 12) **2 

RETURN 

END 

FUNCTION PTOTAL(E,N) 

C 

C This function computes the proton-proton and proton-neutron 

C total cross section according to empirical formulas. 

C It is valid for energies between 40 MeV and 1000 GeV. 

C If N=l (pp) , if N=2 (pn) . Energy in MeV. 



C- 



DIMENSION P(12,2),C{3) 

DATA P/293.3,1.99,35.0, 15.02,2.925,548.3, 
& 1104 . , - .1444, 4091 . , . 1174, 75100 . , . 05061, 
& 1623. ,1.423,30.97,13.08, .9946, 561.9, 
& 2677., -.0586, 25950. , . 0691 , 1 . E6 , 0 . / 

A= (P{1,N) /E) **P{2,N) + P(3,N) 

B=P(4,N) *TANH{P{5,N) *ALOG (E/P (6 , N) ) ) 

DO J=l, 3 



K=2*J+5 
DC=E/P(K,N) 
WC=EXP(-DC) 

C(J)=WC + (1. -WC) *DC**P(K+1,N) 
END DO 

PTOTAL= ( A+B) *C(1)*C(2)*C(3) 
RETURN 
END 

SUBROUTINE LETAW ( I Z , I A , ENERGY , CROS S SECTION) 



This siibroutine computes the total inelastic cross sections 
of nuclides on protons. The formula is taken from: 
Letaw, J.R. , Silberberg, R. , and Tsao,C.H. 1983 , Ap . J. Suppl . , 
51,271. 



REAL lA 

E=l. - .62*EXP (-ENERGY/200. ) *SIN (10 . 9/ENERGY** . 28 ) 
T=45 . *IA** . 7 

T=(1,+.016*SIN(5.3-2.63*LOG(IA) ) ) *T*E 
IF(IZ.EQ.2) T=.8*T 

IF(IZ.EQ,4) T=(1.+.75*EXP {-ENERGY/75. ) ) *T 

CROSS_SECTION=T 

RETURN 

END 




SUBROUTINE CREME96 




rSPORT ( INPUT_FLUX , 

ELOWER , EUPPER , M , I ZLO , I ZUP , 
IPATH, UPATHO , TARGET , SHIELDFILE , 
VERSION_NUMBER, PROGRAM_CODE , 
OUTPUT FLUX) 




********************************************* *********^ 

This subroutine transports an input particle environment through a 
specified thickness and type of shielding. It takes account both 
ionization energy loss (dE/dx) as well as energy- dependent nuclear 
fragmentation. The output is the particle enviroment (differential 
fluxes vs. energy) inside the spacecraft, that is, 'behind' the specified 
shielding. This routine includes many refinements over the old CREME 
transport routine ("INSIDE"). Specifically: 

CREME 9 6_TRANS PORT keeps track of projectile fragments; the old CREME 
code ignored them. This routine also uses improved Silberberg, Tsao, 
and Barghouty energy- dependent fragmentation cross-sections. Both of 
these improvements can be important for thick shielding. 

At present CREME 9 6_TRANS PORT only does aluminum shielding; future 
versions will also offer transport through other shielding materials. 

CREME96_TRANSPORT is based on the "UPROP" code, as originally developed 
by John R. Letaw of Severn Communication Corp. under contract to 
the Gamma & Cosmic Ray Astrophysics Branch of Naval Research Laboratory 
in 1989. Significant improvements and "bug-extermination" have been 
provided by A.F. Barghouty of Roanoke College. 

******************************************** 

IMPLICIT NONE 
CHARACTER* 12 TARGET 
CHARACTER* 8 0 SHIELDFILE 
INTEGER* 4 MARR,NELM 
PARAMETER (MARR=5000 , NELM=92 ) 

REAL* 4 INPUT_FLUX ( NELM , MARR ) , OUTPUT_FLUX ( NELM , MARR ) 

REAL*4 TEMP_INPUT (NELM, MARR) , TEMP_FLUX (NELM, MARR) 

REAL*4 ELOWER, EUPPER, UPATHO , PATH, PSTEP , PSTEPMIN, PSTEPMAX 

REAL* 4 PATHOLD , DELTA_PATH , TEMP_PATH 

INTEGER*4 M, N, NSP, IZLO, IZUP, IPATH, lULABEL 

REAL* 4 UPATH , UUPATH , FRACSHLD 

INTEGER* 4 VERSION_NUMBER, PROGRAM_CODE 

INTEGER*4 MAXSHIELD, NSHIELD, K, lELM, lARR 

PARAMETER {MAXSHIELD=500) 

DIMENSION UPATH (MAXSHIELD) , FRACSHLD (MAXSHIELD) 
CHARACTER* 5 UNITS_LABEL 
DIMENSION UNITS_LABEL(4) 

DATA UNITS_LABEL/ ' g/cm2 ' , 'mils ' , ' cm ','!!!!!'/ 
INTEGER*4 lENT 
DATA IENT/0/ 



WRITE (6, 9998) 

98 FORMAT dx;,' TRANSPORT_DRIVER calculation started.', 
& ' Please stand by.') 

CALL GET_CREME96_VERSION(VERSION_NUMBER) 
PROGRAM CODE =4 



Now set parametes for transport calculation. 
Use recommended default: 

Special version: turns off all nuclear fragmention: 
N=0 

IF (lENT.EQ.O) THEN 
IENT=1 

WRITE (6, 9995) 



95 FORMAT (Ix, ' ! ! ! I SPECIAL VERSION OF CREME96 TRANSPORT !!!!', 
& /, ' All nuclear fragmentation turned off!', 

& /, ' NOTE: The user is responsible for tracking', 

Sc ' to which output files this pertains!') 



ENDIF 

Use straight-ahead approximation; ignore energy spread of target fragments 
(This takes a lot of time and generally has only very small effect.) 
NSP=0 

Set maximum & minimum PSTEP sizes allowed in transport 
PSTEPMIN=0.20 
PSTEPMAX=0.20 
.IUIiABEL=IPATH+l 
IF (IULABEL.GT.4) IULABEL=4 



IF (UPATHO.GT.0.0) THEN 
NSHIELD=1 
UPATHd) =UPATHO 
FRACSHLDd) =1.00 

ELSE 

CALL UNLOAD_SHIELDFILE (SHIELDFILE , NSHIELD , UPATH, FRACSHLD) 
ENDIF 

PATHOLD=0.0 



DO 1000 K=l, NSHIELD 

WRITE(6,999) K,UPATH(K) , UNITS_LABEL ( lULABEL) ,FRACSHLD(K) 
9 FORMATdx,' SHIELDING BIN ',14,' THICKNESS = ' , FIO . 4 , Ix, A5 , 
& ' FRACTION = ' , F8 .4) 

UUPATH=UPATH(K) 

Get shielding thickness (PATH) in g/cm2 and transport step size: 
CALL UNLOAD_PATH (I PATH, UUPATH, TARGET, PATH, PSTEPMIN, PSTEPMAX , PSTEP) 

Now perform transport : 

IF (NSHIELD. EQ.l) THEN 

CALL UPROP96 (INPUT_FLUX, 
& ELOWER,EUPPER,M, IZLO, IZUP, 

& N , NS P , PATH , PSTEP , TARGET , 

& OUTPUT FLUX) 



ELSE 

Modification 8-16-96 by AJT: 

To speed up calculations through thick shielding distributions, 
allow output of one step to be input to the next step. 



DELTA_PATH=PATH- PATHOLD 

IF (DELTA_PATH.LT.O. ) DELTA_PATH=0 . 0 

DO 300 IELM=1,NELM 

DO 200 IARR=1,MARR 

IF (K.EQ.l) THEN 

TEMP_INPUT (lELM, lARR) =INPUT_FLUX ( lELM, lARR) 
TEMP_PATH=PATH 

ELSEIF (K.GT.l .and. DELTA_PATH . LT . PSTEP) THEN 
TEMP_INPUT (lELM, lARR) =INPUT_FLUX { lELM, lARR) 
TEMP_PATH=PATH 

ELSEIF (K.GT.l .and. DELTA_PATH . GE . PSTEP) THEN 

TEMP_INPUT ( lELM, lARR) =TEMP_FLUX { lELM, lARR) 

TEMP_PATH=DELTA_PATH 

ENDIF 
200 CONTINUE 
300 CONTINUE 



CALL UPROP96 (TEMP_INPUT, 
& SLOWER, EUPPER,M, IZLO,IZUP, 

& N , NSP , TEMP_PATH , PSTEP , TARGET , 

& ' TEMP_FLUX). 

PATHOLD=PATH 



Now add to weighted sum: 
DO 500 IELM=1,NELM 

DO 400 IARR=1,MARR 

OUTPUT_FLUX ( lELM, lARR) =OUTPUT_FLUX ( lELM, lARR) + 
& TEMP_FLUX (lELM, lARR) *FRACSHLD (K) 

4 00 CONTINUE 
500 CONTINUE 



ENDIF 



1000 CONTINUE 



WRITE(6, 9999) 

9999 FORMATdx,' TRANSPORT_DRIVER calculation completed. Thank you. 
& /,lx,' All fluxes are in units of particles/m2-s-sr-MeV/nuc ' , 
& ' vs . energy in MeV/nuc . ' , 

& /,lx,' Recommended next step: 
& /, 5x, ' LETSPEC , 

& ' (RUN CREME96 : LETS PEC_DRIVER) ' 

& ' for heavy- ion induced SEUs;', 

& /,2x,' or PUP (RUN CREME96 : PROTON_UPSET_DRIVER) ' , 

& ' for proton- induced SEUs.') 



RETURN 
END 



c 
c 
c 



SUBROUTINE OUTPl 



EME96_DIFLET (LETMIN, LETMAX, LI 

IZLO, I2UP,EMINCUT,EMAX CUT, TARGET, 
VERSION_NUMBER, PROGRAM_CODE , 
INFILE, 
DIFSPEC, 
OUTFILE) 



Routine for writing out the CREME96 differential LET Spectrum. 
IMPLICIT NONE 

REAL*4 LETMIN, LETMAX, EM I NCUT, EMAXCUT, DIFSPEC 
DIMENSION DIFSPEC (1) 

INTEGER* 4 L , 1 2L0 , 1 2UP , LARR , K , NHEADER , NHEADERO , OUTUNIT 

DATA OUTUNIT/2/ 

CHARACTER* 12 TARGET 

CHARACTER* 9 CREATION_DATE 

CHARACTER* 8 CREATION_TIME 

CHARACTER* 80 INFILE , OUTFILE , DLTFILE 

INTEGER*4 VERSION NUMBER , PROGRAM CODE , STAT , CREME96 OPEN 



C FORMAT statements 



100 FORMAT {IX, 2 (IPEIO .4, 2X) , 3 (15, 2X) , A12, 16x, 14, Ix, II) 

150 FORMAT {lx,A79) 

O 200 FORMAT( (IX, 6 {1PE10.4,2X) ) ) 

210 FORMAT( {1X,6 (E10.4,2X) ) ) 

p C Open output file and write header 

ru c 

Q C First, modify name for DIFLET spectrum: 

Q DLTFILE= ' NULLFILE ' 

£7 DO K=2,LEN (OUTFILE) 

[ IF (OUTFILE (K:K) .EQ. '.') THEN 

DLTFILE=0UTFILE(1:K-1)//' .DLT' 
L,, ENDIF 
; ^ ENDDO 

r: IF (DLTFILE. EQ. 'NULLFILE' ) DLTFILE=OUTFILE// ' .DLT' 

j^; c OPEN (UNIT=OUTUNIT, STATUS=' NEW , FILE= ' USER :' //DLTFILE) 

Stat = creme96_open(dltfile, 'user' ,outunit, 'new' ) 
CALL DATE ( GREAT I ON_DATE) 
CALL TIME (CREATION TIME) 



CALL CHECK_HEADER_LENGTH ( INFILE , NHEADERO ) 
NHEADER=NHEADER0+5 

WRITE (OUTUNIT, 990) NHEADER, DLTFILE ( 1 : 70 ) , 
& VERSION_NUMBER, PR0GRAM_C0DE+1 

990 FORMAT (13, lx,A70, 14, Ix, II) 

WRITE (OUTUNIT, 992 ) VERSION_NUMBER, CREATION_DATE , CREATION_TIME 

992 FORMAT ( Ix, ' %Created by CREME96 : LETSPEC_DRIVER Version ',14, 
& ' on ' ,A9, ' at ' ,A8) 

WRITE (OUTUNIT, 993) IZLO, I ZUP , LETMIN, LETMAX, L 

993 FORMAT (Ix, ' %ZMIN =',I3,' ZMAX =',I3, 

& ' LETMIN = ',1PE8.2,' LETMAX = ',1PE8.2, 

& ' MeV-cm2/g LBINS =',I5) 

WRITE (OUTUNIT, 994) EMINCUT 

994 FORMAT (Ix, ' %EMINCUT = ',1PE8.2,' MeV/nuc') 
WRITE (OUTUNIT, 995) TARGET 

995 FORMAT (Ix, ' %TARGET MATERIAL = ',A12) 



Now copy header in^ 




tion from input file : 




WRITE (OUTUNIT, 998) INFILE(1:45) 

FORMAT (Ix, '% Input File to LETSPEC_DRIVER : ' ,A45) 
CALL COPY_HEADERS ( INFILE , NHEADERO , OUTUNIT) 

Finally, output differential LET spectrum: 

WRITE { OUTUNIT ,100) LETMIN , LETMAX , L , I ZLO , I ZUP , TARGET , 
& VERSION_NUMBER, PR0GRAM_C0DE+1 

WRITE (OUTUNIT, 100) 

Write flux to file. 

WRITE (OUTUNIT, 200) (DIFSPEC (K) ,K=1,L) 
CLOSE (OUTUNIT) 



RETURN 



END 



SUBROUTINE OUTPl 




)ME96_DOSE{INFILE, IZMIN, IZMAX^^PtMIN, LETMAX, 
EMINCUT , EMAXCUT , TARGET , MODEL_TYPE , 
VERS ION_NUMBER , PROGRAM_CODE , 
DOSE_PER_SECOND, acc_dose , 
OUTFILE) 




★ 



* 



C 

c 
c 



Routine for writing out the CREME96 dose calculation. 



IMPLICIT NONE 

CHARACTER* 80 INF I LE , OUTFILE 
INTEGER*4 IZMIN, I ZMAX, MODE L_TYPE 
REAL*4 LETMIN,LETMAX, EMINCUT, EMAXCUT 
REAL*4 DOSE_PER_SECOND,acc_dose 
INTEGER*4 NHEADER, NHEADERO , OUTUNIT 
DATA OUTUNIT/2/ 
CHARACTER* 12 TARGET 
CHARACTER* 9 CREATION_DATE 
CHARACTER* 8 CREATION_TIME 

INTEGER*4 VERSION_NUMBER, PROGRAM_CODE , STAT, CREME96_OPEN 
C Open output file and write header 

C OPEN (UNIT=OUTUNIT, STATUS= ' NEW , FILE= ' USER : ' //OUTFILE) 

Stat = creme96_open (out file, ' user' , outunit, ' new' ) 
CALL DATE(CREATION_DATE) 
CALL TIME(CREATION_TIME) 

CALL CHECK_HEADER_LENGTH ( INFILE , NHEADERO ) 
NHEADER=NHEADER0+6 

IF (MODEL_TYPE . EQ . 1 . or . MODEL_TYPE . EQ . 2 ) NHEADER =NHEADER+1 
WRITE (OUTUNIT ,990) NHEADER , OUTFILE (1:70), 
& VERS ION_NUMBER , PROGRAM_CODE 

990 FORMAT (13, lx,A70, 14, 12) 

WRITE (OUTUNIT , 992 ) VERSION_NUMBER , CREATION_DATE , CREATION_TIME 

992 FORMAT (Ix, ' %Created by CREME96 :DOSE_DRIVER Version ',14, 
& ' on ' ,A9, ' at ' , A8) 

IF(MODEL_TYPE.EQ.0) WRITE (OUTUNIT, 900) DOSE_PER_SECOND , acc_dose 
IF(MODEL_TYPE.EQ.l) WRITE (OUTUNIT, 901) DOSE_PER_SECOND , acc__dose 
IF(M0DEL_TYPE.EQ.2) WRITE (OUTUNIT, 902 ) DOSE_PER_SECOND , acc_dose 
IF(M0DEL_TYPE.EQ.3) WRITE (OUTUNIT, 903 ) DOSE_PER_SECOND , acc_dose 

900 FORMAT (' %Average Dose = ',1PE13.6,' rad/sec = ',1PE13.6, 
& ' krad/year' ) 

901 FORMATC %Worst-day average dose rate = ',1PE13.6,' rad/sec ' , 

& /,' %Event-Accumulated Dose = ',1PE13.6,' krad in 18.0 hours.') 

902 FORMATC %Worst-week average dose rate = ',E13.6,' rad/sec', 

& /, ' %Event -Accumulated Dose = ',1PE13.6,' krad in 180.0 hours.') 

903 FORMATC %Peak SEP dose rate = '1P,E13.6,' rad/sec = ', 
& 1PE13.6,' krad/sec') 

WRITE (OUTUNIT, 993) IZMIN, IZMAX, LETMIN, LETMAX 

993 FORMAT (Ix, ' %ZMIN =',I3,' ZMAX ^',13, 

& ' LETMIN = ',1PE8.2,' LETMAX = ',1PE8.2,' MeV-cm2/g' ) 

WRITE (OUTUNIT, 994) EMINCUT, EMAXCUT 

994 FORMAT (Ix, ' %EMINCUT = ',1PE8.2,' EMAXCUT = ',1PE8.2,' MeV/nuC) 
WRITE (OUTUNIT, 995) TARGET 

995 FORMAT (Ix, ' %TARGET MATERIAL = ',A12) 



C Now copy header information from input file : 

WRITE (OUTUNIT, 998) INFILE (1 : 45) 



FORMAT (Ix, ' %Inp^^pile to DOSE_DRIVER: ',A45) 
CALL COPY HEADERS (INFILE,NHEADER0,OUTUNIT) 



CLOSE (OUTUNIT) 



RETURN 
END 



p 



SUBROUTINE OUTPUT_^^E96_FLUX (IZLO, IZHI , ELOWER, EUE 

* YEAR , IMODE , ITRANS , 

* GTRANSFILE , TRAPDFILE , 

* VERS ION_NUMBER , PROGRAM_CODE , 

* M,FLX,OUTFILE) 

C 

C Routine for writing the CREME96 particle environment file. 

C Modified 7/29/96 to add tracking information to header. 
C Modified 8/19/96 to add more detailed header information, 
C per recommendation from Ed Petersen, 

C 

IMPLICIT NONE 

INTEGER*4 IZLO, IZHI , J, K, M, OUTUNIT, STAT, CREME96_OPEN 
DATA OOTUNIT/2/ 

INTEGER*4 NHEADER, NGTFLINES , NTRPLINES 
REAL* 4 ELOWER, EUPPER 
CHARACTER*80 OUTFILE, ILINE 
CHARACTER* 9 CREATION_DATE 
CHARACTER* 8 CREATION_TIME 

INTEGER*4 MARR,NELM 
PARAMETER (MARR=5000 , NELM=92 ) 
REAL* 4 FLX 

DIMENSION FLX(NELM,MARR) 
REAL* 4 YEAR 

INTEGER* 4 IMODE , ITRANS , VERSION_NUMBER, PROGRAM_CODE 

CHARACTER* 8 0 GTRANSFILE , TRAPDFILE 

CHARACTER* 12 TARGET 

DATA TARGET/ ' UNSHIELDED '/ 



yj C FORMAT Statements 

s 100 FORMAT (IX, 2 (1PE10.4,2X) ,3 (I5,2X) ,A12, 

Sc 2X, 0PF8 .3, Ix, 12, Ix, II, Ix, 14, Ix, II) 

fy 150 FORMATdx, A39, lx,A39) 

200 FORMAT( (IX, 6 (1PE10.4, 2X) ) ) 

C Open output file and write header 

C OPEN (UNIT=OUTUNIT, STATUS=' NEW , FILE= ' USER //OUTFILE) 

Stat = creme96_open (outf ile, 'user' ,outunit, 'new' ) 
CALL DATE (GREAT I ON_DATE) 
CALL TIME (CREATION_TIME) 

C 

C Now prepare header for output file: 

NHEADER=3 

IF ( ITRANS. EQ.O) NHEADER=NHEADER+1 
IF ( ITRANS. GE.l) THEN 

CALL CHECK_HEADER_LENGTH (GTRANSFILE , NGTFLINES ) 

NHEADER=NHEADER+2 +NGTFLINES 

ENDIF 

IF (ITRANS. EQ. 2) THEN 

CALL CHECK_HEADER_LENGTH (TRAPDFILE , NTRPLINES ) 
NHEADER=NHEADER+ 1 +NTRPL INES 

ENDIF 

WRITE (OUTUNIT, 990) NHEADER, OUTFILE ( 1 : 70 ) , 
& VERSION_NUMBER, PROGRAM_CODE 

990 F0RMAT(I3, 1X,A70, 14, Ix, II) 

WRITE (OUTUNIT, 992) VERSION NUMBER, CREATION DATE , CREATION TIME 



^^by CREME96 :FLUX_DRIVER Versio(|^I4, 



992 FORMAT (Ix, ' %Crea 
& ' on ' ,A9, ' at ' ,A8) 

C Revised 9/14/96: Energy limits hardwired 

C WRITE (OUTUNIT, 993) IZLO, I2HI , SLOWER, EUPPER, M 

C 993 F0R^4AT(lx, '%ZMIN =',I3,' ZMAX =',I3, 

C & ' EMIN = ',1PE10.4,' EMAX = MPE10.4, 

C & ' MeV/nuc MBINS =',I5) 

WRITE (OUTUNIT, 993) IZLO, IZHI 

993 FORMAT (Ix, ' %ZMIN =',I3,' ZMAX =',I3) 

IF (IMODE.EQ.O) THEN 

WRITE (OUTUNIT, 995) IMODE,yEAR 

995 FORMAT (Ix, ' %IMODE = ',13,' SOLAR -QUIET MODE: YEAR = ',F10.4) 
ELSEIF (IMODE.EQ.l) THEN 

WRITE (OUTUNIT, 996) IMODE 

996 FORMAT (Ix, '% IMODE = ',13, 

& ' WORST-DAY SOLAR ENERGETIC PARTICLE MODEL' ) 

ELSEIF (IM0DE.EQ.2) THEN 

WRITE (OUTUNIT, 997) IMODE 

997 FORMAT (Ix, '% IMODE = ',13, 

& ' WORST- WEEK SOLAR ENERGETIC PARTICLE MODEL') 

ELSE 

O WRITE (OUTUNIT, 998) IMODE 

998 FORMAT (Ix, '% IMODE =',I3,' PEAK 5 -MINUTE -AVERAGED FLUX') 
O ENDIF 

o 

rj IF (ITRANS.EQ.O) THEN 

WRITE (OUTUNIT, 999) ITRANS 
.999 FORMAT (Ix, '% ITRANS = ',13, 

& ' GEOSYNCH/NEAR- EARTH INTERPLANETARY FLUXES') 

ELSEIF ( ITRANS. EQ.l) THEN 

WRITE (OUTUNIT, 899) ITRANS , GTRANSFILE (1 : 40) 
899 FORMAT (Ix, '% ITRANS = ',13, 

& ' INSIDE MAGNETOSPHERE /NO TRAPPED FLUXES', 

& /,lx,'%INPUT GEOMAGNETIC TRANSMISSION FILE : ' , Ix, A40 ) 

CALL COPY_HEADERS (GTRANSFILE , NGTFLINES , OUTUNIT) 

ELSEIF ( ITRANS. EQ. 2) THEN 

WRITE (OUTUNIT, 898) ITRANS , GTRANSFILE ( 1 : 40) 
898 FORMAT (Ix, '% ITRANS = ',13, 

& ' INSIDE MAGNETOSPHERE /TRAPPED PROTONS INCLUDED' , 

& /,lx,'%INPUT GEOMAGNETIC TRANSMISSION FILE : ' , Ix, A40 ) 

CALL COPY_HEADERS (GTRANSFILE, NGTFLINES, OUTUNIT) 

WRITE (OUTUNIT, 897) TRAPDFILE ( 1 : 40 ) 
897 FORMAT (Ix, '% INPUT TRAPPED PROTON FILE: ',llx,A40) 

CALL COPY_HEADERS (TRAPDFILE, NTRP LINES , OUTUNIT) 
ENDIF 

WRITE (OUTUNIT, 100) ELOWER, EUPPER, M, IZLO, IZHI , 
& TARGET , YEAR , IMODE , ITRANS , 

& VERS ION_NUMBER , PROGRAM_CODE 

WRITE (OUTUNIT, 100) 



c 



Write fluxes to file. 



DO J=IZLO,IZHI 

WRITE (OUTUNIT, 2 00) (FLX{J,K) ,K=1,M) 
Skip line between elements. AJT 5/6/96 
WRITE (OUTUNIT, 100) 

END DO 




CLOSE (OUTUNIT) 



RETURN 
END 



?U1^^ME96_LETSPEC (LETMIN, LETMAX, L/^^ 



SUBROUTINE OUTPl 

* I ZLO , I ZUP , EMINCUT , EMAXCUT , TARGET , 

* VERS ION_NUiyiBER , PROGRAM_CODE , 

* INFILE, 

* SPECT, 

* OUTFILE) 

C 

C Routine for writing out the CREME96 integral LET Spectrum. 
C Modified 7/29/96 to add header information. 

C Modified 8/19/96 to add more detailed header information, per 

C recommendation by Ed Petersen. 

C 

IMPLICIT NONE 

REAL*4 LETMIN, LETMAX, EMINCUT, EMAXCUT 

INTEGER* 4 L, I ZLO, IZUP , LARR, K, NHEADER, NHEADERO , OUTUNIT 

DATA OUTUNIT/2/ 

CHARACTER* 12 TARGET 

CHARACTER* 9 CREATION_DATE 

CHARACTER* 8 CREATION_TIME 

PARAMETER (LARR=1002) 

REAL*4 SPECT (LARR) 

CHARACTER* 8 0 INFILE , OUTFILE 

INTEGER*4 VERSION_NUMBER, PROGRAM_CODE , STAT , CREME96_OPEN 



C FORMAT Statements 

□ 100 F0RMAT(1X,2 {1PE10.4,2X) ,3(I5,2X) , A12 , 16x, 14 , Ix, II ) 

O 150 FORMAT (lx,A79) 

rU 200 FORMAT( (1X,6 (1PE10.4,2X) ) ) 

bj C Open output file and write header 

= . c OPEN(UNIT=OUTUNIT, STATUS=' NEW ,FILE=' USER: ' //OUTFILE) 

Stat = creme96_open (outf ile, 'user' ,outunit, 'new' ) 

fU CALL DATE (CREATION DATE) 



CALL TIME (CREATION_TIME) 

CALL CHECK_HEADER_LENGTH ( INFILE , NHEADERO ) 
NHEADER=NHEADERO 4- 5 

WRITE (OUTUNIT, 990) NHEADER, OUTFILE (1 : 70) , 
& VERS ION_NUMBER , PROGRAM_CODE 

990 F0RMAT(I3, Ix, A70, 14, Ix, II) 

WRITE (OUTUNIT, 992) VERSION_NUMBER, CREATION_DATE , CREATION_TIME 

992 FORMAT (Ix, ' %Crea ted by CREME96 : LETSPEC_DRIVER Version ',14, 
& ' on ' , A9 , ' at ' , A8 ) 

WRITE (OOTUNIT, 993) IZLO, IZUP, LETMIN, LETMAX, L 

993 FORMAT ( Ix, ' %ZMIN =',I3,' ZMAX =',I3, 

& ' LETMIN = ',1PE8.2,' LETMAX = ',1PE8.2, 

& ' MeV-cm2/g LBINS =',I5) 

WRITE (OUTUNIT, 994) EMINCUT 

994 FORMAT (Ix, ' %EMINCUT = ' , 1PE8 . 2 , ' MeV/nuC ) 
WRITE (OUTUNIT, 995) TARGET 

995 FORMAT (Ix, ' %TARGET MATERIAL = ',A12) 



C Now copy header information from input file: 

WRITE (OUTUNIT, 998) INFILE (1 : 45) 
998 FORMAT (Ix, '% Input File to LETSPEC_DRIVER : ',A45) 
CALL COPY_HEADERS ( INFILE , NHEADERO , OUTUNIT) 

C Finally, output integral LET spectrum: 



WRITE (OUTUNIT, 100) LETMIN, LETMAX, L, IZLO, IZUP, TARGET, 
& VERS ION__NUMBER , PROGRAM_CODE 

WRITE (OUTUNIT, 100) 

Write flux to file. 

WRITE (OUTUNIT, 200) (SPECT(K) ,K=1,L) 
CLOSE (OUTUNIT) 

RETURN 
END 



SUBROUTINE OUTPUT J^pLD FILE {SHI ELD FILE , 

* COMMENT , lUNITS , MATERIAL , 

* NBINS,XTHICK,XPROB, 

* XMEAN , XRMS , TOTAL , ERRFLAG , 

* VERS ION_NUMBER , PROGRAM_CODE ) 

C 

IMPLICIT NONE 

CHARACTER* 8 0 SHIELDFILE , COMMENT 
INTEGER*4 lUNITS , STAT, CREME96_OPEN 
CHARACTER*12 MATERIAL 

INTEGER*4 NBINS, VERSION_NUMBER, PROGRAM_CODE 

REAL*4 XTHICK, XPROB , XMEAN, XRMS , TOTAL 

INTEGER* 4 ERRFLAG 

DIMENSION XTHICK (1) , XPROB (1) 

INTEGER* 4 NHEADER 

INTEGER* 4 OUTUNIT , lULABEL , K 

DATA OUTUNIT/2/ 

CHARACTER* 9 CREATION_DATE 

CHARACTER* 8 CREATION_TIME 

CHARACTER* 5 UNITS_LMEL 

DIMENSION UNITS_LABEL{4) 

DATA UNITS_LABEL/ ' g/cm2 ' , ' mils ' , ' cm ','!!!!!'/ 

_ C Open output file and write header 

c OPEN {UNIT=OUTUNIT,STATUS=' NEW , FILE= ' USER :' //SHIELDFILE) 

O Stat = creme96_open (shieldfile, ' user ', outunit, ' new' ) 

Q CALL DATE(CREATION_DATE) 

ry CALL TIME (CREATION_TIME) 

O NHEADER=4 

W c 

M: WRITE (OUTUNIT, 990) NHEADER, SHIELDFILE ( 1 : 70 ) , 

= & VERSION_NUMBER,PROGRAM_CODE 

U 990 F0RMAT(I3, Ix, A70, 14, Ix, II) 

flj WRITE (OUTUNIT, 991) VERSION_NUMBER, CREATION_DATE , CREATI0N_TIME 

991 FORMAT ( Ix, ' %Created by CREME96 : SHIELDFILE_DRIVER Version ',14, 
2 & ' on ' ,A9, ' at ' ,A8) 

[^^ WRITE (OUTUNIT, 992) COMMENT ( 1 : 7 8 ) 

992 FORMAT (IX, '%' ,A78) 
""^ IULABEL=IUNITS + 1 

IF {IULABEL.GT.4) IULABEL=4 

WRITE (OUTUNIT, 993) UNITS_LABEL { lULABEL) , MATERIAL, NB INS 

993 FORMAT (Ix, ' %Shielding thicknesses: in ',A5,4x,A12, 

& 3x, ' NBINS = ' , 15) 

IF ( ERRFLAG. EQ.O) WRITE (OUTUNIT , 994 ) XMEAN, XRMS 

994 FORMAT { Ix ' %MEAN = ',E13.6,' RMS = ',E13.6) 

IF ( ERRFLAG. EQ.l) WRITE (OUTUNIT, 995 ) XMEAN , XRMS , TOTAL 

995 FORMAT ( Ix ' %MEAN = ',E13.6,' RMS = ',E13.6, 
& ' Sum Before Renorm = ',E13.6) 

WRITE (OUTUNIT, 996) lUNITS 

996 FORMAT (12) 

DO 1000 K=l, NBINS 

WRITE (OUTUNIT, 999) XTHICK (K) , XPROB (K) 
999 FORMAT(lx,E13.6,5x,E13.6) 
1000 CONTINUE 

CLOSE (OUTUNIT) 



RETURN 



END 



m 

III 



fU 
LiJ 



SUBROUTINE OUTPUT 




rSPORTED_FLUX ( IZLO, IZHI , ELOWEl 
I PATH , UPATH , TARGET , 




rpPER, 



* 



* 



SHIELDFILE, INFILE, 

VERS ION_NUMBER , PROGRAM_CODE , 

M,FLX,OUTFILE) 



* 



* 



Routine for writing the CREME96 transported particle environment file. 
Modified 7/29/96 to add tracking information to header. 
Modified 8/19/96 to add more detailed header information, per 
recommendation by Ed Petersen. 



IMPLICIT NONE 

INTEGER*4 IZLO, IZHI , J, K, M, NHEADER, NHEADERO , lULABEL 

INTEGER*4 OUTUNIT, STAT, CREME96_OPEN 

DATA OUTUNIT/2/ 

REAL* 4 ELOWER,EUPPER 

CHARACTER*80 OUTFILE , ILINE 

CHARACTER* 9 CREATION_DATE 

CHARACTER* 8 CREATION_TIME 

CHARACTER* 5 UNITS_LABEL 

DIMENSION UNITS__LABEL{4) 

DATA UNITS_LABEL/' g/cm2 ' , ' mils ' , ' cm ' , ' I ! M ! ' / 

INTEGER*4 MARR,NELM 
PARAMETER (MARR=5000 , NELM=92 ) 
REAL* 4 FLX 

DIMENSION FLX(NELM,MARR) 
REAL* 4 UPATH 

INTEGER*4 IPATH, IDUM, VERSION_NUMBER, PROGRAM_CODE , NSHDLINES 

DATA NSHDLINES /O/ 

CHARACTER* 8 0 INFILE , SHIELDFILE 

CHARACTER* 12 TARGET 

DATA IDUM/0/ 

FORMAT Statements 

F0RMAT(1X,2 (1PE10.4,2X) ,3 (I5,2X) ,A12, 
& 2X, 0PF8 . 3 , Ix, 12 , Ix, II , Ix, 14 , Ix, II) 

FORMAT (lx,A39, lx,A39) 
FORMAT ( (1X,6 (1PE10.4, 2X) ) ) 

Open output file and write header 

OPEN (UNIT=OUTUNIT, STATUS= ' NEW , FILE= ' USER : ' / /OUTFILE) 
Stat = creme96_open (out file, 'user' ,outunit, 'new' ) 
CALL DATE(CREATION_DATE) 
CALL TIME(CREATION_TIME) 

CALL CHECK_HEADER_LENGTH ( INFILE , NHEADERO ) 
NHEADER=NHEADER0+4 

IF (SHIELDFILE (1: 12) .NE. ' ') THEN 

CALL CHECK_HEADER_LENGTH ( SHIELDFILE , NSHDLINES ) 
NHEADER=NHEADER+NSHDLINES 

ENDIF 

WRITE (OUTUNIT, 990) NHEADER, OUTFILE { 1 : 70) , 
Sc VERS ION_NUMBER , PROGRAM_CODE 

FORMAT ( 13, lx,A70, 14, Ix, II) 



WRITE (OUTUNIT, 992) VERS ION_NUMBER, GREAT ION_DATE, GREAT I ON_TIME 

992 FORMAT (Ix, ' %Grea ted by CREME96 : TRANSPORT_DRIVER Version ',14, 
& ' on ' ,A9, ' at ' ,A8) 

WRITE (OUTUNIT ,993) I ZLO , I ZHI , ELOWER , EUPPER , M 

993 FORMAT (Ix, '%ZMIN =',I3,' ZMAX =',I3, 

& ' EMIN = ',1PE10.4,' EMAX ^ ',1PE10.4, 

& ' MeV/nuc MB INS =',I5) 

IUIiABEL= I PATH+ 1 
IF (IULABEL.GT.4) IUIiABEL=4 

IF (SHIELDFILE{1:12) .NE. ' ') THEN 

WRITE (OUTUNIT, 997) SHIELDFILE (1:50) 
FORMAT (Ix, ' %Shielding distribution: ',A50) 
CALL GOPy_HEADERS (SHIELDFILE, NSHDLINES , OUTUNIT) 
ELSE 

WRITE (OUTUNIT, 996) UPATH, UNITS_LABEL ( lULABEL) , TARGET 
FORMAT (Ix, '%Thickness = ' , FIO . 4 , Ix, A5 , 5x, A12 ) 
ENDIF 



997 



996 



Now copy header information from input file : 
WRITE (OUTUNIT, 998) INFILE(1:45) 

FORMAT ( Ix, '% Input File to TRANSPORT_DRIVER : ' ,A45) 
GALL GOPY_HEADERS ( INFILE , NHEADERO , OUTUNIT) 

O" G Finally, output transported spectra: 

fU WRITE (OUTUNIT, 100) ELOWER , EUPPER, M, I ZLO, I ZHI, 

p & TARGET , UPATH , I PATH , IDUM , 

Ly & VERSION_NUMBER,PROGRAM_GODE 

U WRITE (OUTUNIT, 100) 



G Write fluxes to file. 

E Li 

DO J= I ZLO, I ZHI 

WRITE (OUTUNIT, 200) (FLX(J,K) ,K=1,M) 
Skip line between elements. AJT 5/6/96 
WRITE (OUTUNIT, 100) 
END DO 

CLOSE (OUTUNIT) 





RETURN 
END 



PA^^S ( ENERGY , I Z , I A, NAME , MEAN_FR^8ll 



SUBROUTINE PAI^pLS ( ENERGY , I Z , I A, NAME , MEAN_FREl^ilTH , 

& NSP,ELOSS, NORMALIZATION) 

This program computes the charge changing mfps 
for the nuclide (Iz/lA) on material NAME at ENERGY MeV/N. 
The target nuclides are (JZ,JA) and the products are (KZ,KA) 

C INCLUDE 'CREME96:ZCOMMON.CMN' 

CHARACTER* 12 NAME 

REAL NA{28) ,IADJ{28) ,NASPM(28) ,DENS,ETAD 

INTEGER NZ (28) , IGAS,NAS 

COMMON /TBLOCK/DENS,ETAD, IGAS,NAS, 
& NZ,NA, IADJ,NASPM, 

& NTOTAL , AVGZ , AVGZ2 , AVGA , AVGI 

REAL MEAN_FREE_PATH(100) ,CR(100) ,ELOSS(100) , NORMALIZATION 
REAL IA,JA,KA 

DATA AVOGADRO/6.022045E23/ ! particles/mole 

CALL ZTARGET(NAME) 

FACT= 1 . E2 7 *AVGA/AVOGADRO 

NORMALIZATION=0 . 

DO KZ=3,IZ+1 

MEAN_FREE_PATH (KZ) =0 . 
DO K=KZ,3*K2 
Q KA=FLOAT{K) 
DO L=1,NAS 
□ JZ=NZ{L) 
n JA=NA(L) 

m c 

g C The following modulates the projectile energy by the number of 

fjj C TARGET participants, July 1992: 

2 IF{NINT(JA) .EQ.l) THEN 

E=AMIN1 (ENERGY* JA, 10000 . ) 

U ^^^^ 
^ AP^IA 

AT=JA 

CALL GLAUBER ( AP , AT , AP_P , AT_P ) 
PART=AT_P+AP_P 
DELTA=IA-KA 

A_EFF=AT_P* (1 . +TANH ( (DELTA- PART) /PART) ) 
E=AMIN1 ( ENERGY* A_EFF, 10000 . ) 
END IF 

CALL YIELDX(IZ,NINT (lA) ,KZ,NINT(KA) , AMAXl (E , 100 . ) ,S) 
IF (KZ.EQ.4.AND.K.EQ.8) S=0 . 
IF (KZ.EQ.5.AND.K.EQ. 9) S = 0 . 
IF (S.LT.l.E-4) S=0. 

CALL SCALER ( I Z,NINT(IA) , JZ , NINT ( JA) 7KZ , NINT (KA) , 
& AMAXl (ENERGY, 100. ) ,SC) 

MEAN_FREE_PATH (KZ) =MEAN_FREE_PATH ( KZ ) +S*SC*NASPM (L) 
NORMALIZATION=NORMALIZATION+S*SC*NASPM (L) *KZ 
END DO 
END DO 

MEAN_FREE_PATH (KZ) =MEAN_FREE_PATH ( KZ ) /FACT/NTOTAL 
END DO 

MEAN_FREE_PATH ( 2 ) = 0 . . 
DO K2=l,3 

IF {K2.EQ.1) KZ=2 
IF (K2.EQ.2) KZ=4 
.IF (K2 .EQ.3) KZ=5 



. IF (K2.£Q.l]^^4 

IF (K2.EQ.2) K=8 
IF (K2.EQ.3) K=9 
KA= FLOAT (K) 
DO L=1,NAS 

JZ=NZ (L) 

JA=NA(L) 

The following modulates the projectile energy by the number 
TARGET participants, July 1992: 
IF{NINT(JA) -EQ.l) THEN 

E=AMIN1 ( ENERGY* JA, 10000 . ) 
ELSE 
AP=IA 
AT=JA 

CALL GLAUBER { AP , AT , AP_P , AT_P ) 

PART=AT_P+AP_P 

DELTA=IA-KA 

A_EFF=AT_P* (1 . +TANH ( (DELTA- PART) /PART) ) 
E=AMIN1 {ENERGY*A_EFF, 10000 . ) 
END IF 

CALL YIELDX{IZ,NINT(IA) ,KZ,NINT(KA) ,AMAX1 (E, 100. ) ,S) 
IF (KZ.EQ.4 .OR.KZ.EQ. 5) S=S*2 . 
IF (S.LT.l.E-4) S=0. 

CALL SCALER (IZ,NINT(IA) , JZ,NINT(JA) ,KZ,NINT(KA) , 
AMAXl (ENERGY, 100 . ) , SC) 

MEAN_FREE_PATH(2) =MEAN_FREE_PATH(2) +S*SC*NASPM(L) 
N0RMALIZATI0N=N0RMALI2ATI0N+S*SC*NASPM(L) *2 . 
END DO 
END DO 

MEAN_FREE_PATH ( 2 ) =MEAN_FREE_PATH ( 2 ) /FACT/NTOTAL 
NORMAL IZ AT I 0N=N0RMAL I Z AT ION/ FACT/NTOTAL 

Energy-loss calculations: Sept. 1993 

IF(NSP.EQ. 0) RETlTRN 
DO KZ=1, IZ+1 
ELOSS(KZ)=0. 
CR(KZ)=0. 
DO K=KZ,3*KZ 
KA= FLOAT (K) 
DO L=1,NAS 
JZ=NZ (L) 
JA=NA(L) 

The following modulates the projectile energy by the number 
TARGET participants, July 1992: 
IF(NINT(JA) .EQ.l) THEN 

E=AMIN1 (ENERGY*JA, 10000 . ) 
ELSE 

AP=IA 
AT=JA 

CALL GLAUBER ( AP , AT , AP_P , AT_P ) 

PART=AT_P+AP_P 

DELTA=IA-KA 

A_EFF=AT_P* (1 . +TANH ( (DELTA- PART) /PART) ) 
E=AMIN1 ( ENERGY* A_EFF, 10000 . ) 
END IF 




CALL YIELDX(IZ,NINT(IA) ,KZ,NINT(KA) , AMAXl (E , 100 . ) ,S) 



IF (KZ.EQl^^P^.K.EQ.8) S=0 . 

IF (KZ.EQ. 5 .AND.K.EQ. 9) S=0 . 
IF (S.LT.l.E-4) S=0. 

CALL SCALER ( I Z,NINT(IA) , JZ,NINT(JA) ,KZ,NINT(KA) , 
AMAXl (ENERGY, 100 . ) , SC) 

CALL E_LOSS(IZ,NINT(IA) , JZ,NINT(JA) ,KZ,NINT(KA) , 

ENERGY, dKE, SigmaKE) 
dKE=dKE+0 . * SigmaKE 

CR{KZ)=CR{KZ)+S*SC*NASPM(L) /NTOTAL 
IF(KZ.EQ.l) THEN 

ELOSS (KZ) =ELOSS (KZ) +dKE* (REAL (KA) /6 . ) *NASPM (L) 
/NTOTAL 

ELSE 

ELOSS (KZ) =ELOSS (KZ) +dKE*S*SC*NASPM(L) /NTOTAL 
END IF 
END DO 
END DO 

IF(CR(KZ) .NE.O.AND.KZ.GT.l) THEN 

ELOSS (KZ) =ELOSS (KZ) /CR (KZ) 
END IF 

END DO 



RETURN 
END 



SUBROUTINE SCALER ( IZl , lAl , IZ2 , IA2 , JZ , JA, E , SC) 
DATA IENT/0/ 
IF (lENT.EQ.O) THEN 
IENT=1 



TYPE *, 
TYPE *, 
TYPE *, 
END IF 



Using STB scaling algorithm- 1992 



SC 




1 . 


IF 


(IA2.EQ.1) 


SL 




1. 


SI 




1 . 


SD 




1 . 


Zl 




IZl 


Al 




lAl 


Z2 




IZ2 


A2 




IA2 


Z 




JZ 


A 




JA 


El 




E/1000. 


SC 




1.6 + 0.0 



RETURN 



New scaling algorithm: 
SC=ASYMM(A1,A2) 



July 1992 



FA =(1.0 + (Al/l20.)*AMINl(El,2.)/2.)/(l.+Al/l20.) 

IF (JZ.LE.5) SL = (1. + .4*(1.+.02*(Z1/Z)**2)*(1.-1.5*Z/Z1) ) 

IF (A .LT.Al/2. .AND. JZ.GT.5) SD = 3 . *EXP { - (2 . *A/A1) ) *FA 

IF (lAl-JA.EQ. 1) SI = (1. + .0014*Z1*Z2** (1.8- .005*Z2) ) /SC 

SC = SC*SL*S1*SD 

END 



SUBROUTINE GLAUBER (AP , AT, AP P,AT P) 



calculates (average) number of proj . and target participants; 



according to Gll^^pbr theory. 



DATA PI, RO/3. 14159, 1.36/ 
DATA P13,P23/0. 33333, 0.66667/ 

AP_P=AP * AT**P23 / {AP**P13+AT**P13) **2 
AT_P=AT * AP**P23 / (AP**P13+AT**P13 ) **2 
RETURN 
END 

FUNCTION ASYiy[M(AP,AT) 

calculates asymmetry and participant contributions: 
DATA PI, RO/3. 14159, 1.36/ 
DATA P13,P23/0. 33333, 0.66667/ 

CALL GLAUBER ( AP , AT , AP_P , AT_P ) 

EXPO=EXP ( - (AP-AT) / (AT+AP) ) 
RHO= (AP-1 . ) / (AP+1 . ) 

CONST=EXP (-RHO) I Normalization constant. 

ASYMM=CONST* (AP/AP_P) *EXPO 

RETURN 

END 



t J^^^^ it ★ « * * ★ * * -it ★ St ★ * * * 4 ★ ★ ★ ★ * * ★ * it * '^^l^^'A 



C 

C Module: PC_ROUTINES 

c 

c 

c Logical Names and Environment Variables serve the same purpose, 

c but are handled differently, on the two CREME96 platforms (VAX and 

c PC respectively) . There are also differences between the two file 

c OPEN statements. To enable platform independance where fully 

c specified filenames and where file opens are used in the higher 

c level CREME96 code, two versions exist of the routines to perform 

c these tasks. When an executable is being created, it is the 

c responsibility of the person performing the link to ensure that the 

c appropriate set of routines is used for the current build. 

c 

c 

c Two platform- DEPENDANT routines exist: 
c 

c CREME96_FULL_FILENAME creates fully-specified filename 

c CREME96_OPEN performs a file OPEN on full filename 

C SHOW_DIRECTORY gives advice when file not found. 

c 

c These routines reside in the following 2 physical files: 
— c 

Q c VAX_ROUTINES.FOR used for a VAX build 

^ c PC_ROUTINES . FOR used for a PC build (this file) 

S c 

Q Q********************************** ********** 



W=5 



integer function creme96_open (filename, path, unit , status) 



c FILENAME: The non- fully specified name of the target file, 

c 

c PATH: Contains the DOS Environment Variable pointing to 

c the directory where file does, or will exist. 

c 

c UNIT: The logical unit to be associated with the file, 

c Must be defined at the time of the function call 

c (one will not be assinged by this routine) . 

c 

c STATUS: Contains either OLD, for existing file, or 

c NEW, to create a file. 

c 

c Calling example: 

c 

c STAT = creme96_open (' input . dat' creme96 inunit, ' old' ) 

c 

c Success is indicated by a ZERO return value. Otherwise, the 

c return value will contain the FORTRAN error code. 

c 

c 

IMPLICIT NONE 

character*80 filename, file, full_f ilename, line 
character*10 path 
integer unit,ios 
character* 7 status 



file = full_fi]]^^Pie (filename, path) 



if (status (1:1) .eq. 'o' .or. status (1:1) .eq. 'O') then 
c Old files are only opened for READ (no APPEND in CREME) . 

c Any file opened for READ will be opened SHARED. 



OPEN(UNIT=unit, f ile=f ile, status='old' , 
& mode='read' , share=' denywr' , iostat=ios, err=199) 

c DEBUG 

c read (unit , 99) line 

c99 format (a80) 

c write (*,*)' First line in file: ' , line 
else 

c New file to be created. WRITE and NOSHARE are default. On the PC, 

c we must open with REPIiACE instead of NEW, in case a file already 

c exists of this name (as it is our intention to write over it) . If 

c one doesn't exist, REPLACE acts the same as NEW. 

OPEN(UNIT=unit, file=f ile , status= ' replace ' , 
& iostat=ios, err=199) 

c DEBUG 

c write (*,*)' Writing test line to new file...' 

c write (unit ,*)' Test line' 

endif 

199 creme96_open_f ile = ios 

return 



end 

c 

c************ *********************************** ********** 
c 

character*80 function full_filename (filename, path) 

use msflib 
IMPLICIT NONE 

character* 80 filename, dir 
character*10 path 
integer lendir 



c The variable PATH contains the name of the environment variable 

c which in turn points to the directory path of the target file, 

c The function GETENVQQ will translate this environment variable 

c into the program variable DIR. 



lendir = getenvqq (path (1 : len_trim (path) ), dir) 

full_f ilename = dir (1 : lendir) //' \ ' //filename 

return 
end 

c 

c*** ******************************** ****************************************** 
c 

SUBROUTINE SHOW_DIRECTORY ( JFILETYPE) 

C 

C PC version. 



c 




C The VAX version of this routine uses LIB$SPAWN to echo back a copy 

C of the user's directory when this routine becomes activated (because 

C the requested file was not found, etc. ) However, no comparable 

C capability exists on the PC. We therefore just print out statements 

C which recommend that the user open another window and check his/her 

C directory. 

C 

INTEGER* 4 JFILETYPE 



IF (JFILETYPE. EQ. 0) THEN 
WRITE (6, 9010) 

9010 FORMAT (Ix,' Please open another window and', 

& ' check the directory of your current USER area : ' ) 

ELSEIF ( JFILETYPE. EQ.l) THEN 
WRITE (6, 9011) 

9011 FORMAT (Ix,' Please open another window and', 
Sc ' check the directory of your * . tr* files.') 

ELSEIF ( JFILETYPE. EQ. 2) THEN 
WRITE(6, 9012) 

9012 FORMAT (Ix,' Please open another window and', 
& ' check the directory of your *.gt* files.') 

ELSEIF (JFILETYPE. EQ. 3) THEN 
WRITE(6, 9013) 

9013 FORMAT (Ix,' Please open another window and', 

& ' check the directory of your particle flux files:',/, 
& ' *.flx, *.tfx, *.tr*' ) 

ELSEIF { JFILETYPE. EQ. 4) THEN 
WRITE (6, 9014) 

9014 FORMAT (Ix,' Please open another windw and', 

& ' check the directory of your particle flux files:',/, 
& ' *.tfx, *.flx, *.tr*') 

ELSEIF ( JFILETYPE. EQ. 5) THEN 
WRITE(6, 9015) 

9015 FORMAT (Ix,' Please open another window and', 
& ' check the directory of your *.LET files.') 

ELSEIF ( JFILETYPE. EQ. 6) THEN 
WRITE (6, 9016) 

9016 FORMAT (Ix,' Please open another winow and', . 
Sc ' check the directory of your *.DLT files.') 

ELSEIF ( JFILETYPE. EQ. 7) THEN 
WRITE(6,9017) 

9017 FORMAT (Ix,' Please open another window and', 
& ' check the directory of your *.SHD files.') 

ELSEIF (JFILETYPE. EQ. 8) THEN 
WRITE (6, 9018) 

9018 FORMAT (Ix,' Please open another window and', 
& ' check the directory of your *.XSD files.') 



ENDIF 



WRITE (6, 9999) 



9999 FORMAT {/) 
RETURN 
END 
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SUBROUTINE PRi 



UPSETS (PROTON_FILE, IP ARAM, P/ 
& XSECT_FILE,NBITS, lENTER, 

& SEU_RATE , DAY_RATE , PERSECOND , PERDAY) 

Subroutine for performing proton SEU evaluation: 



C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

c- 
c 



Inputs: PROTON_FILE = file containing proton differential flux 

(in protons/m2-s-sr-MeV) vs. energy (in MeV) 
IPARAM = 1/2,4, indicating cross -section model 

1 = Bendel 1 -parameter 

2 = Bendel 2 -parameter 
4 = Weibull 

0 = table 

PARAMS{4) = array containing cross-section parameters 

XSECT_FILE = file containing cross-section table. 
lENTER = steering flag, for multiple calculations with 

the same proton spectrum. 

Outputs: SEU_RATE in SEUs/s/bit 

DAY_RATE in SEUs/bit/day 

PERSECOND in SEUs/device/second 

PERDAY in SEUs/ device /day 



Written by: 



Last update: 



Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 . nrl . navy . mil 

20 August 1996 



IMPLICIT NONE 

INTEGER*4 NB INS , NPTS , IPARAM, I ENTER 
REAL*4 EN,FLUX,PARAMS,XSECT,NBITS, 

SEU_RATE , DAY_RATE , PERSECOND , PERDAY 
CHARACTER* 8 0 PROTON_FILE , XSECT_FILE 

PARAMETER (NBINS = 5 000) 

DIMENSION EN(NBINS) ,FLUX(NBINS) , XSECT (NBINS ) 
DIMENSION PARAMS{4) 



WRITE (6, 9998) 

9998 FORMAT (Ix,' PROTON_UPSET_DRIVER calculation started. 
& ' Please stand by. ' ) 



SEU_RATE=0 . 0 

C 

C On first entry, get proton spectrum: 

IF (lENTER.EQ.l) THEN 

CALL UNLOAD_PROTON_SPECTRUM (PROTON_FILE, EN, FLUX, NPTS) 



ENDIF 



Evaluate proton 




cross -section at these energ' 




lues : 



CALL EVALUATE_SEU_CROSS_SECTION (EN, NPTS , IPARAM, PARAMS , 



Calculate SEU rate: 

CALL INTEGRATE_PROTON_UPSETS (NPTS , EN , FLUX , XSECT , SEU_RATE ) 



IF ( SEU_RATE . LT . 0 . ) THEN 
WRITE (6,999) SEU_RATE 

FORMAT (Ix,' ERROR in PROTON_UPSETS : SEU RATE = ',E13.5) 
SEU RATE=0.0 



CALL CALC_SEU_RATE (NBITS , SEU_RATE , DAY_RATE , PERSE COND, PERDAY) 
WRITE (6, 9999) 

FORMAT (Ix,' PROTON_UPSET_DRIVER calculation completed. ') 



XSECT FILE, XSECT) 



ENDIF 



RETURN 
END 



Lii 



PROGRAM PROTOI^jiET_DRIVER 

IMPLICIT NONE 

REAL*4 NBITS , PARAMS , SEU_RATE , DAY_RATE , PERSECOND , PERDAY 
REAL*4 XDUM 

INTEGER*4 IPARAM, IREPEAT, lENTER 
DIMENSION PARAMS (4) 

CHARACTER* 80 PROTON_FILE , XSECT_FILE , REPORT_FILE 
CHARACTER*40 DEVICE_LABEL 
INTEGER* 4 lERR 
DATA IERR/0/ 

IENTER=1 



10 CONTINUE 

CALL INITIALIZE_PROTON__UPSETS ( PROTON_FILE , NBITS , 
& IPARAM, PARAMS, XSECT__FILE, lENTER, 

& DEVICE LABEL, REPORT FILE) 



CALL PROTON_UPSETS ( PROTON_FILE , IPARAM , PARAMS , XSECT_FILE , 
& NBITS, lENTER, 

& SEU RATE, DAY RATE, PERSECOND, PERDAY) 



CALL PROTON_UPSET_REPORT{PROTON_FILE, NBITS, 
& IPARAM, PARAMS, XSECT_FILE, lENTER, 

& DEVICE_LABEL , REPORT_FILE , 

& SEU_RATE , DAY_RATE , PERSECOND , PERDAY) 

9100 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 9200) 

9200 FORMAT(//,' Repeat SEU rate calculation with different', 

& ' device characteristics? (l=yes, 0=no) ' ) 

READ(*, *,ERR=9100, IOSTAT=IERR) IREPEAT 
IF { IREPEAT . EQ . 1 ) THEN 
IENTER=IENTER+1 
GOTO 10 
ENDIF 

WRITE (6, 9600) 

9600 FORMATdx,' Proton Upset calculations finished.') 



STOP 
END 



SUBROUTINE PR0T03I5^SET_REP0RT ( PROTON_FILE , NBITS , ' 
& IPARAM,PARAMS,XSECT__FILE, lENTER, 

& DEVICE_LABEL , REPORT_FILE , 

& SEU_RATE , DAy_RATE , PERSECOND , PERDAY) 



IMPLICIT NONE 

REAL*4 NBITS , PARAMS , SEU_RATE , DAY_RATE , PERSECOND , PERDAY 

INTEGER*4 IPARAM, lENTER, OUTUNIT , VERSION_NUMBER, NHEADERO , K 

INTEGER* 4 NHEADER, PROGRAM_CODE , STAT, CREME96_OPEN 

DATA OUTUNIT/ 2/ 

D IMENS I ON PARAMS ( 4 ) 

CHARACTER*8 0 , PROTON_FILE , XSECT_FILE , REPORT_FILE 
CHARACTER*4 0 DEVICE_LABEL 
CHARACTER* 9 CREATION_DATE 
CHARACTER* 8 CREATION TIME 



PROGRAM C0DE=9 



IF ( lENTER . EQ . 1 . and . REP0RT_FILE . NE . ' NULLFILE ' ) THEN 
C OPEN (UNIT=OUTUNIT,FILE=' USER: ' //REPORT_FILE , STATUS= ' NEW ) 

Stat = creme96_open (report_f ile, 'user' ,outunit, 'new' ) 
CALL DATE{CREATION_DATE) 
CALL TIME(CREATION_TIME) 
O CALL GET_CREME96_VERSION(VERSION_NUMBER) 

CALL CHECK_HEADER_LENGTH ( PROTON_FILE , NHEADERO ) 

□ NHEADER=NHEADER0+2 

p WRITE (OUTUNIT, 991) NHEADER , REPORT_FILE (1 : 70 ) , 

m & VERSION_NUMBER, PROGRAM_CODE 

□ 991 FORMAT(I3,lx,A70,I4,I2) 

WRITE (OUTUNIT, 992 ) VERSION__NUMBER, CREATION_DATE, CREATION_TIME 
^7 992 FORMAT (Ix, ' %Created by CREME96 : PROTON_UPSET_DRIVER Version ',14, 
[ Sc ' on ' , A9 , ' at ' , A8 ) 

Li C Now copy header information from. input file: 

WRITE (OUTUNIT, 993) PROTON_FILE ( 1 : 40) 
Y: 993 FORMAT (Ix, '% Input Proton Spectrum File: ' ,A40) 
^ CALL COPY_HEADERS ( PROTON_FILE , NHEADERO , OUTUNIT) 

^ ENDIF 

IF (REPORT_FILE . NE . ' NULLFILE ' ) THEN 
WRITE (OUTUNIT, 994) I ENTER, DEVI CE_LABEL 

994 FORMAT (/, Ix, ' REPORT NO. ',14,': ',2x,A40) 

IF (IPARAM. EQ. 0) WRITE (outunit , 980 ) IPARAM, XSECT_FILE (1 : 75) 
IF (IPARAM. EQ. 1) WRITE (outunit , 981) IPARAM, PARAMS (1) 
IF (IPARAM. EQ. 2) WRITE (outunit , 982 ) IPARAM, PARAMS (1) , PARAMS (2) 
IF (IPARAM. EQ. 4) WRITE (outunit , 984 ) IPARAM, (PARAMS (K) , K=l , 4 ) 
WRITE (outunit, 996) NBITS 

996 ' FORMAT (Ix,' Number of bits = ',E13.5) 



980 FORMATdx, ' CROSS -SECTION INPUT ',13,' FROM FILE: 

& /,5x,A75) 

'981 FORMATdx,' CROSS- SECTION INPUT ',13, 

& ' BENDEL 1-PARAMETER = ',E13.5) 

982 FORMATdx,' CROSS-SECTION INPUT ',13, 

& ' BENDEL 2-PARAMETERS A,B = ',2E13.5) 

984 FORMATdx,' CROSS-SECTION INPUT ',13, 

& ' WEIBULL FIT: ' , 

& //5x,' ONSET = ',F9.3,' MeV , 

& /,5x,' WIDTH = ',F9.3,' MeV, 



= ' , F9 . 3 , ' (dimensionless^P^ 

& /,Syi,' PLATEAU = ',F9.3,' x 10**-12 cm2/bit' ) 



WRITE (outunit , 9200) 

WRITE {outunit, 9201) lENTER, SEU_RATE , DAY_RATE , PERSECOND , PERDAY 
9200 FORMAT (2x, 'Rates: SEUs/bit/second /bit/day', 

& ' /device/second /device/day' ) 

92 01 FORMAT {2x, ' ★****' , 14 , 2x, 4 {E14 . 5 , 2x) ) 

ENDIF 

WRITE (6, 9200) 

WRITE (6 , 9201) lENTER, SEU_RATE, DAY_RATE, PERSECOND, PERDAY 

RETURN 
END 



ru 

; . ; 



SUBROUTINE RANGj^pf N , Z 0 , Al , NAME , R ) 
********************************************************* 

* THIS PROGRAM TABULATES THE RANGE OF NUCLIDE (Z0,A1) IN 

* A STOPPING MEDIUM 'NAME' AT ENERGIES GIVEN IN THE ARRAY 

* E IN MeV/nucleon. 

********************* ******* *************** ********* 
CHARACTER* 12 NAME 

DIMENSION E(N) ,R(N) ,GX(4) ,GA(4) 
COMMON AVGZ , AVGZ2 , AVGA, AVGI 
DATA NGAUSS/8/ 

DATA GX/1. 96028986, 1.79666648, 1.52553241, 1.18343464, 
& 0.81656536, 0.47446759, 0.2 0333352, 0. 03 971014/ 

DATA GA/0. 10122854, 0.22238103, 0.31370665, 0.36268378, 
& 0.36268378, 0.31370665, 0.22238103, 0.10122854/ 

DATA NGAUSS/4/ 

DATA GX/1. 86113631, 1.33998104, 0.66001896, 0.13886369/ 
DATA GA/0. 34785485, 0.65214515, 0.65214515, 0.34785485/ 

SS=STPOW(E (1) , ZO, A1,NAME) 

JTEST=0 

DO J=1,N 

IF (E(J) .LE.O.) THEN 
R{J)=0. 

ELSE 

IF (JTEST.EQ.O) THEN 

ELAST=0. 

RLAST=0. 

JTEST=1 
ELSE 

ELAST=E(J-1) 

RLAST=R(J-1) 
ENDIF 

DE=(E(J)-ELAST)/2. 

R(J)=0. 

DO K=1,NGAUSS 

STEMP=STPOW(ELAST+DE*GX{K) , Z0,A1,NAME) 
IF (STEMP.GT.O. ) R ( J) =R ( J) +GA (K) /STEMP 

END DO 

R (J) =DE*R (J) +RLAST 
ENDIF 
END DO 
RETURN 
END 




r^Hf^TPUT ( I ERR 



SUBROUTINE RETfl 
C 

C NOTE: A non-zero input value of lERR will be re- set to zero 

C by this routine. 

C 

IMPLICIT NONE 
INTEGER* 4 lERR 
LOGICAL RETRY 

C Logical flag RETRY may be set to .FALSE, to suppress repitition 

C of question after an incorrect response. In this case, an 

C error message is printed and execution is terminated. This feature 

C may be useful in the WWW version of the code, which is not truly 

C interactive. 

DATA RETRY/ . TRUE . / 

C 

IF (lERR.NE.O) THEN 

IF ( . NOT . RETRY ) THEN 
WRITE (6, 667) 

667 FORMAT C® 00001 ABNORMAL TERMINATION: 

& /,lx,' ERROR IN RETRY_INPUT: 

& /,lx,' ERROR in user-supplied input. STOP') 

STOP 

ELSE 

WRITE (6, 665) lERR 
665 FORMAT (/,' ERROR ON INPUT: VAX ERROR CODE = ',15, 

& ' PLEASE TRY AGAIN. ' ) 

IERR=0 

ENDIF 
ENDIF 

RETURN 
END 



• 

LUX{IZ,EN, IMODE) 



REAL FUNCTION 
C 

C Returns the interplanetary Solar Energetic Particle differential flux 

C for element IZ, energy EN (MeV/nuc) in one of two modes: 

C 

C IM0DE=1: "Worst Day": particle fluxes based on observations from 

C GOES (protons) and IMP -8 (heavy ions) for the 18 -hour 

C period beginning at 1300 UT on 20 OCT 1989. 

C IM0DE=2 : "Worst Week": particle fluxes based on observations from 

C GOES (protons) and IMP -8 (heavy ions) for the 180 -hour 

C period beginning at 1300 UT on 19 OCT 1989. 

C NOTE: The actual termination time here is somewhat arbitrary, 

C since only a few percent of the flux was accumulated 

C during the last day. 

C IM0DE=:3 : Peak flux, based on peak 5-minute average flux observed on 

C GOES in October 1989 

C 

C 

C Average particle flux for this specified period is returned in 

C units of ions/m2-s-sr-MeV/nuc . 

C 

IMPLICIT NONE 

INTEGER*4 IZ , IMODE , NSEP , K, lUSE 

REAL*4 EN, HOURS , SOLAR_PROTONS , ERRFLUX , SOLAR_HEAVY_IONS 

REAL*4 ETEMP 

CHARACTER*? LSEP, LABEL 

DIMENSION HOURS (3) , NSEP (2) , LSEP (4) 

DATA HOURS/18.0,180.0,0.083333/ 

DATA NSEP/ 1,4/ 

DATA LSEP/'20OCT89' , '190CT89' , '220CT89' , '240CT89'/ 



SEP_FLUX=0.0 

IF (EN.LT.1.0 .or. EN.GT. l.OE+5) RETURN 
IF ( IMODE. LT.l .or. IMODE. GT. 3) RETURN 



IF (IZ.EQ.l) THEN 
ETEMP=EN 

IF {ETEMP.GT.600. ) ETEMP=600. 
IF (IM0DE.LT.3) THEN 
DO 1000 K=l, NSEP (IMODE) 
LABEL=LSEP(K) 

SEP_FLUX=SEP_FLUX+SOLAR_PROTONS (ETEMP, LABEL, ERRFLUX) 
1000 CONTINUE 



ELSEIF (IM0DE.EQ.3) THEN 
LABEL='PEAKFLX' 

SEP_FLUX=SOLAR_PROTONS (ETEMP , LABEL, ERRFLUX) 
ENDIF 



Match high-energy extrapolation to alpha spectrum; AJT 12/27/96 

IF (IM0DE.NE.2) SEP_FLUX=SEP_FLUX* (ETEMP/EN) **4. 14060 
IF (IM0DE.EQ.2) SEP_FLUX=SEP_FLUX* (ETEMP/EN) **3 . 76100 

ELSEIF (IZ.EQ.2) THEN 
IUSE=6 

Use D. Reames nominal He/C ratio: 

SEP_FLUX=122 . 5*S0LAR_HEAVY_I0NS (lUSE, EN, IMODE , ERRFLUX) 
Fine-tune using the GOES alpha flux at -7.3 MeV/nuc 
IF (IMODE. NE. 2) SEP FLUX=0 . 85*SEP FLUX 



IF (IMODE 

ELSE 



.^^) SEP_FLUX=0 . 70*SEP_FLUX ^jj^ 



SEP_FLUX=SOLAR_HEAVY_IONS (12, EN, IMODE , ERRFLUX) 
ENDIF 



Fluence evaluation completed. Now normalize by elapsed time 

SEP_FLUX=SEP_FLUX/ ( HOURS ( IMODE ) *3600 . ) 
IF (SEP_FLUX.LT.O. ) SEP_FLUX=0 . 0 
RETURN 
END 



C SHELLIG.FOR, Versl^^.O, January 1992 




C 11/1/91 SHELLG: lowest starting point for BO search is 2 
C 1/27/92 Adopted to IGRF-91 coeffcients model 

C 2/5/92 Reduce variable -names : INTER (P) SHC, EXTRA (P) SHC, INI TI(ALI) ZE 

C 12/9/92 DGRF/IGRF file names changed by AJT 

C Changes in FELDCOF, for initialization purposes 

C 

C******** ************* ***★★****★*♦★ 

C SUBROUTINES FINDBO, SHELLG, STOER, FELDG, FELDCOF, GETSHC, 

C INTERSHC, EXTRASHC, INITIZE ' i 

C 



C 



SUBROUTINE FINDBO ( STPS , BDEL , VALUE , BEQU, RRO ) 



C FINDS SMALLEST fdAGNETIC FIELD STRENGTH ON FIELD LINE 
C 

C INPUT: STPS STEP SIZE FOR FIELD LINE TRACING 

C COMMON/FIDBO/ 

C SP DIPOLE ORIENTED COORDINATES FORM SHELLG; P(l,*), 

C P(2,*),P(3,*) CLOSEST TO MAGNETIC EQUATOR 

C BDEL REQUIRED ACCURACY = [ B(LAST) - BEQU ] / BEQU 

C B(LAST) IS FIELD STRENGTH BEFORE BEQU 

C 

C OUTPUT: VALUE =. FALSE . , IF BEQU IS NOT MINIMAL VALUE ON FIELD LINE 

C BEQU MAGNETIC FIELD STRENGTH AT MAGNETIC EQUATOR 

C RRO EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS 

C BDEL FINAL ACHIEVED ACCURACY 



C- 



DIMENSION P(8.4),SP{3) 
LOGICAL VALUE 
COMMON /FIDBO/ SP 

C 

STEP=STPS 
IRUN=0 
7777 IRUN=IRUN+1 

IFdRUN.GT.S) THEN 

VALUE= . FALSE . 

GOTO 8888 

ENDIF 

C*********************FiRST THREE POINTS 
P(1,2)=SP(1) 
P(2,2) =SP(2) 
P(3,2)=SP(3) 
STEP=-SIGN(STEP,P(3,2) ) 
CALL ST0ER(P(1,2) ,BQ2,R2) 
P(l,3) =P(1,2)+0.5*STEP*P(4,2) 
P(2, 3) =P{2,2)+0.5*STEP*P(5,2) 
P(3,3) =P(3,2)+0.5*STEP 
CALL STOER(P(l,3) ,BQ3,R3) 
P(1,1)=P(1,2)-STEP* (2.*P(4,2) -P{4,3) ) 
P(2,1)=P(2,2) -STEP* (2.*P(5,2) -P(5,3) ) 
P(3,1)=:P(3,2)-STEP 
CALL ST0ER(P(1,1) ,BQ1,R1) 

P{1,3)=P{1,2)+STEP*{20.*P(4,3) -3 . *P (4 , 2) +P (4 , 1) ) /18 

P(2,3)=P{2,2)+STEP* (20.*P(5,3) -3 . *P (5 , 2) +P (5 , 1) ) /18 

P(3,3)=P(3,2)+STEP 

CALL ST0ER(P(1,3) ,BQ3,R3) 



^♦♦♦★★♦★★★★★★★★★★♦♦IN^^^^ggjjgg jp REQUIRED 
IF{BQ3 .LE.BQl) G^TO 2 
STEP=-STEP 
R3=R1 
BQ3=BQ1 
DO 1 1=1,5 

ZZ = P(I, 1) 
P(I,1)=P(I,3) 

1 P{I,3)=Z2 

C** **************** INITIALIZATION 

2 STEP12=STEP/12 . 
VALUE= . TRUE . 
BMIN=1.E4 
B0IiD=l.E4 

C******************cORRECTOR (FIELD LINE TRACING) 
N=0 

5555 P(l,3) =P(1,2)+STEP12* (5 . *P (4 , 3 ) +8 . *P (4 , 2 ) -P (4 , 1) ) 
N=N+1 

P(2,3) =P(2,2) +STEP12* (5 . *P (5 , 3) +8 . *P (5 , 2) -P (5 , 1) ) 
C******************pREDICTOR (FIELD LINE TRACING) 

P(l,4) =P(1,3)+STEP12* (23.*P(4,3) -16.*P(4,2)+5.*P(4, 1) ) 
P(2,4) =P(2, 3) +STEP12* (2 3 . *P ( 5 , 3 ) - 16 . *P { 5 , 2 ) +5 . *P ( 5 , 1 ) ) 
P{3,4) =P(3, 3)+STEP 
CALL ST0ER(P(1,4) ,BQ3,R3) 
DO 1111 J=l,3 
DO 1111 1=1,8 
1111 P(X, J)=P{I, J+1) 
B=SQRT(BQ3) 
IF(B.LT.BMIN) BMIN=B 
IF(B.LE.BOLD) THEN 
BOLD=B 
R0LD=1./R3 
SP(1)=P(1,4) 
SP(2)=P(2,4) 
SP(3)=P(3,4) 
GOTO 5555 
ENDIF 

I F ( BOLD . NE . BMIN) THEN 

VALUE=. FALSE. 

ENDIF 
BDELTA= (B-BOLD) /BOLD 
I F ( BDELTA . GT . BDEL ) THEN 

STEP=STEP/10. 

GOTO 7777 

ENDIF 

8888 RR0=ROLD 
BEQU=BOLD 
BDEL=:BDELTA 
RETURN 
END 



C 
C 



SUBROUTINE SHELLG (GLAT, GLON, ALT, DIMO, FL, ICODE, BO) 



C CALCULATES L- VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE 
C AND GEMAGNETIC FIELD MODEL. 

C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTER, INTERNAL NOTE 
C NO. 67, 1970. 

C G. KLUGE, COMPUTER PHYSICS COMMUNICATIONS 3, 31-35, 1972 



C- 



C CHANGES (D. BILITZA,^^ 87) 

C - USING CORRECT DIPOL MOMENT I . E DIFFERENT COMMON/MODEL/ 
C - USING IGRF EARTH MAGNETIC FIELD MODELS FROM 1945 TO 1990 

C- 

C INPUT: ENTRY POINT SHELLG 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 



GLAT GEODETIC LATITUDE IN DEGREES (NORTH) 
GLON GEODETIC LONGITUDE IN DEGREES (EAST) 
ALT ALTITUDE IN KM ABOVE SEA LEVEL 

ENTRY POINT SHELLC 

V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) 
X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE 
Y-AXIS POINTING TO EQUATOR AT 90 LONG. 
Z-AXIS POINTING TO NORTH POLE 



DIMO 

COMMON 

X(3) 
H(144) 



DIPOL MOMENT IN GAUSS (NORMALIZED TO EARTH RADIUS) 



NOT USED 

FIELD MODEL COEFFICIENTS ADJUSTED FOR SHELLG 



c 


OUTPUT: FL 


L-VALUE 


c 


ICODE 


= 1 NORMAL COMPLETION 


c 




=2 UNPHYSICAL CONJUGATE POINT (FL MEANINGLESS) 


c 




=3 SHELL PARAMETER GREATER THAN LIMIT UP TO 


c 




WHICH ACCURATE CALCULATION IS REQUIRED; 


c 




APPROXIMATION IS USED. 


c 


BO 


MAGNETIC FIELD STRENGTH IN GAUSS 




DIMENSION 


V(3) ,U(3, 3) ,P(8, 100) ,SP(3) 


c 


The following was 


an unlabeled common, which I have appropriately 


c 


named. AJT 12-3 0 


-92. 




COMMON/ BAS TARDS / 


X(3),H(144) 




COMMON/FIDBO/ 


SP 




COMMON/ GENER/ 


UMR , ERA , AQUAD , BQUAD 



c 

c- 

c- 

c- 

c 



RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF IC0DE=2 AND 3 
STEP IS STEP SIZE FOR FIELD LINE TRACING 
STEQ IS STEP SIZE FOR INTEGRATION 



/0.05,1.01/ 
/O. 20, 0.03/ 



TO BE USED WITH GEODETIC CO-ORDINATES 



DATA RMIN,RMAX 
DATA STEP, STEQ 
BEQU=1.E10 
C*****ENTRY POINT SHELLG 
RLAT=GLAT*UMR 
CT=SIN(RLAT) 
ST=COS(RLAT) 

D=SQRT (AQUAD- (AQUAD-BQUAD) *CT*CT) 

X(l) = (ALT+AQUAD/D) *ST/ERA 

X (3 ) = (ALT+BQUAD/D) +CT/ERA 

RLON=GLON*UMR 

X(2) =X(1) *SIN(RLON) 

X(1)=X(1)*C0S(RL0N) 

G0T09 

ENTRY SHELLC (V,FL, BO) 
C*****ENTRY POINT SHELLC TO BE USED WITH CARTESIAN CO-ORDINATES 
X(1)=V(1) 
X(2)=V{2) 
X(3)=V(3) 

C*****CONVERT TO DIPOL -ORIENTED CO-ORDINATES 



SHEL0080 

SHELOlOO 
SHELOllO 



SHEL0160 
SHEL0170 
SHEL0180 
SHEL0190 
SHEL0200 
SHEL0210 
SHEL0220 
SHEL023 0 
SHEL0240 



DATA U/ +0.3511737, -0.9148385,^Pt993679, 

A +0.9335804, +0.3583680, +0.0000000, 

B +0.0714471, -0. 1861260, +0. 9799247/ 

9 RQ=1./{X(1)*X(1)+X(2) *X(2)+X(3)*X(3) ) 

R3H=SQRT (RQ*SQRT (RQ) ) 

P{1,2) = (X(1)*U(1,1)+X(2) *U(2,1)+X(3) *U(3,1) )*R3H 
P{2,2) = {X(1)*U(1,2)+X(2)*U{2,2) ) *R3H 

P{3,2) = (X{1)*U(1,3)+X{2)*U(2,3)+X(3)*U{3,3) )*RQ 
C*****FIRST THREE POINTS OF FIELD LINE 
STEP=-SIGN(STEP,P(3,2) ) 
CALL ST0ER(P(1,2) ,BQ2,R2) 
B0=SQRT(BQ2) 

P(l, 3)=P(1,2) +0.5*STEP*P(4,2) 

P (2 , 3) =:P (2 , 2 ) +0 . 5*STEP*P {5 , 2 ) 

P (3, 3) =P (3, 2) +0 . 5*STEP 

CALL ST0ER(P{1,3) ,BQ3,R3) 

P(l, 1)=P(1,2) -STEP* (2. *P (4, 2) -P{4,3) ) 

P(2,1)=P{2,2) -STEP* (2.*P(5,2) -P{5,3) ) 

P(3, 1)=P(3,2) -STEP 

CALL ST0ER(P(1,1) ,BQ1,R1) 

P{1,3)=P(1,2)+STEP* (20.*P{4,3) -3.*P{4,2)+P(4,1) )/l8. 
P(2,3)=P(2,2)+STEP* (20.*P{5,3)-3.*P{5,2)+P{5,1) )/l8. 
P(3,3)=P{3,2) +STEP 
CALL ST0ER(P{1,3) ,BQ3,R3) 
C*****INVERT SENSE IF REQUIRED 
IF (BQ3 . LE . BQl ) GOT02 
STEP=-STEP 
R3=R1 
BQ3=BQ1 
DO 1 1=1,7 
ZZ=P(I, 1) 
P(I,1)=P{I,3) 

1 P(I,3)=Z2 

C*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH 

2 IF(BQl.LT.BEQU) THEN 

BEQU^BQl 

IEQU=1 

ENDIF 

I F ( BQ2 . LT . BEQU) THEN 

BEQU=BQ2 

IEQU=2 

ENDIF 
IF (BQ3.lt. BEQU) THEN 

BEQU=BQ3 

IEQU=3 

ENDIF 

C*****INITIALIZATION OF INTEGRATION LOOPS 
STEP12=STEP/12. 
STEP2=STEP+STEP 
STEQ=SIGN (STEQ, STEP) 
FI = 0. 
IC0DE=1 
ORADIK=0. 
OTERM=0 . 
STP=R2*STEQ 
Z=P(3,2)+STP 
STP=STP/0.75 

P(8,1)=STEP2*(P(1,1)*P{4,1)+P(2,1)*P(5,1) ) 
P{8,2)=STEP2*(P(1,2)*P(4,2)+P(2,2) *P(5,2) ) 
C*****MAIN LOOP (FIELD LINE TRACING) 



SHEL0250 
. SHEL0260 
SHEL02 70 

SHEL02 90 

SHEL0300 

SHEL0310 

SHEL032 0 

SHEL0330 

SHEL0340 

SHEL0350 

SHEL0360 

SHEL0370 

SHEL0380 

SHEL0390 

SHEL0400 

SHEL0410 

SHEL0420 

SHEL043 0 

SHEL0440 

SHEL0450 

SHEL0460 

SHEL0470 

SHEL048 0 

SHEL0490 

SHEL0500 

SHEL0510 

SHEL0520 

SHEL053 0 

SHEL054 0 

SHEL0550 

SHEL0560 

SHEL0570 



SHEL0580 

SHEL0600 
SHEL0610 
SHEL0620 
SHEL0630 
SHEL0640 
SHEL0650 
SHEL0660 
SHEL0670 

SHEL0690 
SHEL0700 
SHEL0710 



DO 3 N=3,3333 
C*****CORRECTOR (FIELri^TNE TRACING) 

P{1,N)=P(1,N-1)+STEP12*(5.*P(4,N)+8.*P{4,N-1) -P{4,N-2) ) 
P{2,N)=P(2,N-1)+STEP12*{5.*P(5,N)+8.*P(5,N-1) -P(5,N-2) ) 
C*****PREPARE EXPANSION COEFFICIENTS FOR INTERPOLATION 
C*****OF SLOWLY VARYING QUANTITIES 

P(8,N)=STEP2*(P(1,N)*P(4,N)+P(2,N) *P{5,N) ) 

C0=P(1,N-1) **2+P{2,N-l) **2 

C1=P(8,N-1) 

C2=(P(8,N) -P(8,N-2) )*0.25 
C3=(P(8,N)+P(8,N-2) -Cl-Cl)/6.0 
D0=P(6,N-1) 

D1={P(6,N) -P(6,N-2) )*0.5 
D2=(P(6,N) +p(6,N-2) -DO-DO) *0.5 
E0=P(7,N-1) 

El=(P{7,N)-P(7,N-2))*0.5 

E2= (P(7,N) +P(7,N-2) -EO-EO) ♦0.5 
C*** ♦♦INNER LOOP (FOR QUADRATURE) 
4 T=(Z-P{3,N-1))/STEP 

IF(T.GT.l. )G0T05 

HLI=0 . 5* ( ( (C3*T+C2) *T+C1) *T+CO) 
ZQ=Z*Z 

R=HLI+SQRT (HLI*HLI+2Q) 
IF (R . LE . RMIN) G0T03 0 
fj RQ=R*R 
7q FF=SQRT (1 . +3 . *ZQ/RQ) 

Q RADIK=BO- { {D2*T+D1) *T+DO) *R*RQ*FF 

^ IF(R-RMAX)44,44,45 
SI 45 ICODE=2 

RADIK=RADIK-12 . * (R-RMAX) **2 
44 IF(RADIK+RADIK.LE.ORADIK) GOTO 10 

TERM=SQRT (RADIK) *FF* ( (E2*T+E1) *T+EO) / (RQ+ZQ) 
FI=FI+STP* (OTERM+TERM) 
ORADIK=RADIK 
OTERM=TERM 
STP=R*STEQ 

Z=:Z + STP 

G0T04 

C*****PREDICTOR (FIELD LINE TRACING) 

5 P(1,N+1)=P{1,N)+STEP12* (23.*P(4,N) - 16 . *P (4 , N- 1) +5 . *P (4 , N- 2 ) ) 

P(2,N+1)=P{2,N)+STEP12* (23.*P(5,N) - 16 . *P (5 , N- 1) +5 . *P ( 5 , N-2 ) ) 
P(3,N+1) =P(3,N)+STEP 
CALL ST0ER{P(1,N+1) ,BQ3,R3) 
C*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH 
IF(BQ3.LT.BEQU) THEN 
IEQU=N+1 
BEQU=BQ3 
ENDIF 
3 CONTINUE 
10 IF (IEQU.lt. 2) IEQU=2 
SP(1)=P(1,IEQU-1) 
SP(2)=P(2,IEQU-1) 
SP(3)=P(3,IEQU-1) 
IF(ORADIK.LT.lE-15)GOT011 

FI = FI+STP/0 . 75*0TERM*0RADIK/ (ORADIK- RADIK) 



3=i . 



43 



c 

C-- 
C-- 
C-- 
C 



SHEL0720 
SHEL0730 
SHEL0740 
SHEL0750 
SHEL0760 
SHEL0770 
SHEL0780 
SHEL07 90 
SHEL0800 
SHEL0810 

SHEL0830 
SHEL0840 
SHEL0850 

SHEL0870 
SHEL0880 
SHEL0890 
SHEL0900 
SHEL0910 
SHEL0920 



SHEL0950 

SHEL0970 
SHEL0980 
SHEL0990 
SHELIOOO 
SHELlOlO 

SHEL1030 
SHEL1040 
SHEL1050 
SHEL1060 
SHEL1070 
SHEL1080 
SHEL1090 
SHELllOO 
SHELlllO 
SHEL1120 
SHEL1130 
SHEL1140 



SHEL1150 



The minimal allowable value of FI was changed from lE-15 to lE-12, 
because lE-38 is the minimal allowable arg. for ALOG in our envir! 
D. Bilitza, Nov 87. 



iT(BO) +1E-12 
AND I. SAME AS CARMEL IN INVAR 




11 FI=0.5*ABS (FI) 
C*****COMPUTE L FROM^ 
C 

C-- Correct dipole moment is used here. D. Bilitza, Nov 87 
C 

DIMOB0=DIMO/B0 

XX=ALOG(FI*FI*FI/DIMOBO+1E-12) 
IF(XX.GT.23.0) GOTO 776 
GOTO 775 
GOTO 774 
GOTO 773 
GOTO 772 



ladded lE-12, 5-14-96, PRB. 



IF {XX. GT. 11. 7) 
IF(XX.GT.+3.0) 
IF (XX. GT. -3.0) 
IF(XX,GT. -22. ) 

771 GG=3.33338E-1*XX+3.0062102E-1 
GOT0777 

772 GG=( (((((( (-8 . 1537735E-14*XX+8.3232531E-13) *XX+1 . 0066362E- 9) *XX+ 
18.1048663E-8) *XX+3 . 2916354E-6) *XX+8 . 2711096E-5) *XX+1 . 3 714667E- 3 ) * 
2XX+1 . 5017245E-2) *XX+4 . 3432642E-1) *XX+6 . 2337691E-1 

GOT0777 

773 GG=( ( ( ( ( ( ( (2.6047023E-10*XX+2.3028767E-9) *XX-2 . 1997983E-8) *XX- 
15.3977642E-7) *XX- 3 . 3408822E-6 ) *XX+3 . 8379917E- 5) *XX+1 . 1784234E- 3 ) * 
2XX+1.4492441E-2) *XX+4 . 3352788E-1) *XX+6 . 228644E- 1 

G0T0777 

774 GG={ ( { ( ( ( { (6.3271665E-10*XX-3,958306E-8) *XX+9.9766148E-07) *XX- 
11.2531932E-5) *XX+7 . 9451313E- 5 ) *XX- 3 . 2077032E-4 ) *XX+2 . 16803 98E- 3 ) * 
2XX+1.2817956E-2) *XX+4 . 3510529E-1) *XX+6 . 222355E-1 

GOT0777 

775 GG=( { ( ( (2.8212095E-8*XX-3.8049276E-6) *XX+2 . 170224E-4 ) *XX-6. 731033 
lE-3) *XX+1 . 2038224E-1) *XX-1 . 8461796E-1) *XX+2 . 0O07187E0 

GOT0777 

776 GG=XX-3.0460681E0 

777 FL=EXP(ALOG( (l.+EXP{GG) ) *DIMOB0) /3 .0) 
RETURN 

C*****APPROXIMATION FOR HIGH VALUES OF L. 



30 



C 
C 



IC0DE=3 

T=-P(3,N-1) /STEP 

FL=1-/{ABS( ( (C3*T+C2)*T+C1)*T+C0)+1E-15) 

RETURN 

END 



SUBROUTINE STOER (P, BQ, R) 



C 
C 



C**************** *********** 

C* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG * 

C* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG * 
C****************************************^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 

DIMENSION P(7) ,U(3,3) 

The following was an unlabeled common, which I have appropriately 
named. AJT 12-30-92. 
COMMON/BASTARDS/ XI (3) ,H{144) 

C*****XM,YM,2M ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES 
ZM=P(3) 

FLI=P(1) *P (1) +p (2) *P(2) +1E-15 

R=0.5* (FLI+SQRT(FLI*FLI+(2M+ZM) **2) ) 

RQ=R*R 

WR=SQRT(R) 

XM=P(1) *WR 

YM=P{2) *WR 

C*****TRANSFORM TO GEOGRAPHIC CO-ORDINATE SYSTEM 

DATA U/ +0.3511737,-0.9148385,-0.1993679, 
A +0 . 9335804, +0. 3583680, +0 . 0000000, 



SHEL1250 
SHEL1260 
SHEL1270 
SHEL1280 
SHEL12 90 
SHEL1300 
SHEL1310 
SHEL1320 
SHEL13 30 
SHEL134 0 
SHEL1350 
SHEL1360 
SHEL1370 
SHEL1380 
9SHEL1390 
SHEL1400 
SHEL1410 
SHEL1420 

SHEL144 0 
SHEL1450 
SHEL1460 
SHEL1470 
SHEL1480 
SHEL14 90 
SHEL1500 



SHEL1510 



SHEL154 0 
SHEL1550 



SHEL1590 
SHEL1600 
SHEL1610 
SHEL1620 
SHEL1630 
SHEL1640 



B 



ru 



+ 0.0714471, -0. 1861260,^^799247/ 

XI (1) =XM*U(1, i^YM*U(l, 2)+2M*U(l,3) 
XI (2) =XM*U{2, 1) +YM*U(2, 2) +ZM*U(2, 3) 
XI(3)=XM*U(3,1) +ZM*U(3,3) 
C*****COMPUTE DERIVATIVES 
C CALL FELDI (XI, H) 

CALL FELDI 
Q=H(1)/RQ 

DX=H(3) +H(3) +Q*XI (1) 

DY=H(4)+H(4)+Q*XI(2) 

DZ=H(2)+H(2)+Q*XI(3) 
C*****TRANSFORM BACK TO GEOMAGNETIC CO-ORDINATE SYSTEM 

DXM=U{1, 1) *DX+U(2, 1) *DY+U(3, 1) *DZ 

DYM=U(1,2) *DX+U(2,2) *DY 

DZM=U (1,3) *DX+U (2,3) *DY+U ( 3 , 3 ) *DZ 

DR= (XM*DXM+YM*DYM+2M*DZM) /R 
C*****FORM SLOWLY VARYING EXPRESSIONS 

P (4) = (WR*DXM-0 . 5*P (1) *DR) / (R*DZM) 

P (5) = (WR*DYM-0 . 5*P (2) *DR) / (R*DZM) 

DSQ=RQ* {DXM*DXM+DYM*DYM+DZM*DZM) 

BQ=DSQ*RQ*RQ 

P(6) =SQRT(DSQ/ (RQ+3.*ZM*2M) ) 
P(7) =P(6) * (RQ+ZM*ZM) / (RQ*DZM) 
RETURN 
END 

C 
C 

SUBROUTINE FELDG (GLAT, GLON, ALT, BNORTH, BEAST, BDOWN, BAB S) 
C 

C CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL 

C REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61, 

C 1970. 

C 

C CHANGES (D. BILITZA, NOV 87) : 

C - FIELD COEFFICIENTS IN BINARY DATA FILES INSTEAD OF BLOCK DATA 
C - CALCULATES DIPOL MOMENT 

C 

C INPUT: ENTRY POINT FELDG 

C GLAT GEODETIC LATITUDE IN DEGREES (NORTH) 

C GLON GEODETIC LONGITUDE IN DEGREES (EAST) 

C ALT ALTITUDE IN KM ABOVE SEA LEVEL 

C 

C ENTRY POINT FELDC 

C V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) 

C X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE 

C Y-AXIS POINTING TO EQUATOR AT 90 LONG. 

C 2 -AXIS POINTING TO NORTH POLE 

C 

C COMMON BLANK AND ENTRY POINT FELDI ARE NEEDED WHEN USED 

C IN CONNECTION WITH L-CALCULATION PROGRAM SHELLG. 

C 

C COMMON /MODEL/ AND /GENER/ 

C UMR = ATAN(1.0)*4./180. < DEGREE >* UMR=< RAD I ANT > 

C ERA EARTH RADIUS FOR NORMALIZATION OF CARTESIAN 

C COORDINATES (6371.2 KM) 

C AQUAD, BQUAD SQUARE OF MAJOR AND MINOR HALF AXIS FOR 

C EARTH ELLIPSOID AS RECOMMENDED BY INTERNATIONAL 

C ASTRONOMICAL UNION (6378.160, 6356.775 KM). 

C NMAX MAXIMUM ORDER OF SPHERICAL HARMONICS 

C TIME YEAR (DECIMAL: 1973.5) FOR WHICH MAGNETIC 



SHEL1650 
SHEL1660 
SHEL1670 
SHEL1680 
SHEL16 90 

SHEL1700 
SHEL1700 
SHEL1710 
SHEL1720 
SHEL1730 
SHEL1740 
SHEL1750 
SHEL1760 
SHEL1770 
SHEL1780 
SHEL1790 
SHEL1800 
SHEL1810 
SHEL1820 



SHEL18S0 
SHEL1860 
SHEL1870 
SHEL1880 



SHEL1890 



c 

c 

c 

c- 

c 

c 

c 

c 

c 

c- 



G(M) 



lELD IS TO BE CALCULATED 
NORMALIZED FIELD COEFFICIENTS (SEE FELDCOF) 
M-NMAX* (NMAX+2) 



OUTPUT: BABS MAGNETIC FIELD STRENGTH IN GAUSS 

BNORTH, BEAST, BDOWN COMPONENTS OF THE FIELD WITH RESPECT 
TO THE LOCAL GEODETIC COORDINATE SYSTEM, WITH AXIS 
POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST 
AND DOWNWARD. 



C 
C 



DIMENSION V(3) ,B(3) 

CHARACTER*30 NAME ! 5-14-96, change from 17 to 30 

The following was an unlabeled common, which I have appropr 
named. AJT 12-30-92. 

COMMON/BASTARDS/ XI (3) ,H (144) 

COMMON/MODEL/ NAME , NMAX , TIME , G (14 4 ) 

COMMON/GENER/ UMR , ERA , AQUAD , BQUAD 



iately 



IS RECORDS ENTRY POINT 



FELDG TO BE USED WITH GEODETIC CO-ORDINATES 



C 
C- 
C 

C*****ENTRY POINT 
IS = 1 
RLAT=GLAT*UMR 
CT=SIN(RLAT) 
ST=COS(RLAT) 

D=SQRT (AQUAD- ( AQUAD - BQUAD ) *CT*CT) 

RLON=GLON*UMR 

CP=COS(RLON) 

SP=SIN(RLON) 

ZZZ= (ALT+BQUAD/D) *CT/ERA 

RHO= (ALT+AQUAD/D) *ST/ERA 

XXX=RHO*CP 

YYY=RHO*SP 
GOTOlO 

ENTRY FELDC(V,B) 

C*****ENTRY POINT FELDC TO BE USED WITH CARTESIAN CO-ORDINATES 
IS = 2 

XXX=V(1) 
YYY=V(2) 
ZZZ=V(3) 

10 RQ=1 . / {XXX*XXX+YYY*YYY+ZZZ*ZZZ) 

XI (1)=XXX*RQ 

XI (2)=YYY*RQ 

XI(3)=Z2Z*RQ 

GOTO20 

ENTRY FELDI 
C*****ENTRY POINT 

IS = 3 

20 IHMAX=NMAX*NMAX+1 

LAST= IHMAX+NMAX+NMAX 

IMAX=NMAX+NMAX- 1 

DO 8 I=IHMAX,LAST 
8 H{I)=G(I) 

DO 6 K=l,3,2 

I=IMAX 

IH=IHMAX 
1 IL=IH-I 

F=2./FLOAT(I-K+2) 

X=XI(1)*F 

Y=XI(2)*F 



FELDI USED FOR L COMPUTATION 



SHEL192 0 
SHEL1930 

SHEL1950 
SHEL1960 
SHEL1970 

SHEL1990 
SHEL2000 



SHEL2030 
SHEL2040 
SHEL2050 
SHEL2060 
SHEL2070 
SHEL2090 
SHEL2100 
SHEL2110 
SHEL2120 

SHEL2140 

SHEL2150 

SHEL2160 

SHEL2170 

SHEL2180 

SHEL2190 

SHEL2200 

SHEL2210 

SHEL2220 

SHEL2230 

SHEL2240 

SHEL2250 

SHEL2260 

SHEL2270 

SHEL2280 

SHEL2290 

SHEL2300 

SHEL2310 

SHEL2320 





3 
4 
5 



C 
C 

C- 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c- 



2=XI(3)*(F+F]( 
1 = 1-2 
IF(I-l) 5,4,2 
DO 3 M=3,I,2 

H ( IL+M+1 ) =G ( IL+M+1 ) +Z*H ( IH+M+1 ) +X* (H ( IH+M+3 ) -H ( IH+M- 1 ) ) 

^ -Y* (H(IH+M+2) +H(IH+M-2) ) 

H ( IL+M) =G ( IL+M) +2*H ( IH+M) +X* {H ( IH+M+2 ) -H ( IH+M- 2 ) ) 

A +Y* (H (IH+M+3 )+H(IH+M-l) ) 

H{IL+2) =G(IL+2)+2*H(IH+2) +X*H(IH+4) -Y* (H ( IH+3 ) +H ( IH) ) 
H(IL+1) =G(IL+1)+Z*H(IH+1) +Y*H{IH+4)+X* (H(IH+3) -H(IH) ) 
H{IL) =G (IL) +Z*H(IH) +2 . * (X*H(IH+1) +Y*H {IH+2) ) 
IH=IL 

IF(I.GE.K) GOTOl 
CONTINUE 

IF(IS.EQ.3)RETURN 

S=.5*H(l)+2.* (H(2)*XI(3)+H(3)>XI(1)+H{4)*XI(2) ) 

T= (RQ+RQ) *SQRT (RQ) 

BXXX=T* (H{3) -S*XXX) 

BYYY=T* (H (4 ) -S*YYY) 

B2ZZ=T* (H(2) -S*ZZZ) 

IF(IS.EQ.2)GOT07 

BABS=SQRT(BXXX*BXXX+BYYY*BYYY+BZZZ*BZZ2) 

BEAST=BYYY*CP-BXXX*SP 

BRHO=BYYY*SP+BXXX*CP 

BNORTH=BZZZ*ST-BRHO*CT 

BDOWN=-BZZZ*CT-BRHO*ST 

RETURN 

B(l) =BXXX 

B{2) =BYYY 

B(3)=BZZZ 

RETURN 

END 



SHEL2330 

SHEL2340 

SHEL2350 

SHEL2360 

SHEL23 70 

SHEL2380 

SHEL2390 

SHEL2400 

SHEL2410 

SHEL2420 

SHEL2430 

SHEL2440 

SHEL2450 

SHEL2460 

SHEL24 70 

SHEL2480 

SHEL2490 

SHEL2500 

SHEL2510 

SHEL2520 

SHEL2 53 0 

SHEL2 550 
SHEL2 560 
SHEL2 570 
SHEL2 580 
SHEL2590 
SHEL2600 
SHEL2610 
SHEL2620 
SHEL263 0 
SHEL2640 



SUBROUTINE FELDCOF (YEAR, DIMO) 

DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS 

INPUT: YEAR DECIMAL YEAR FOR WHICH GEOMAGNETIC FIELD IS TO 
BE CALCULATED 

OUTPUT: DIMO GEOMAGNETIC DIPOL MOMENT IN GAUSS (NORMALIZED 
TO EARTH'S RADIUS) AT THE TIME (YEAR) 
D. BiLITZA, NSSDC, GSFC, CODE 633, GREENBELT, MD 20771, 
(301)286-9536 NOV 1987. 

Modified by AJT 12-9-92: 

allow for multiple calls: field paramters are not read in unless 
year value is changed. Call to INITIZE also added here. 

CHARACTER*30 FILMOD, FILl, FIL2 ! 5-14-96, change from 17 to 30 
DIMENSION GH1(144) ,GH2(120) , GHA ( 144 ), FILMOD ( 11) ,DTEM0D(11) 

DOUBLE PRECISION X,FO,F 
COMMON/MODEL/ FILl , NMAX , TIME , GHl 
COMMON/GENER/ UMR , ERAD , AQUAD , BQUAD 



DATA 



C 
C 
C 
C 



& 
& 
1 
& 



FILMOD/ 
' creme96 : dgrf 4 5 . dat ' 
'creme96 : dgrf 50.dat' 

' creme96 :dgrf 55 .dat ' , 
'creme96 : dgrf 65 .dat' 



' creme96 : dgrf 60 . dat ' 





^ ^ ^■'creme96:dgrf70.dat' , ' creme9l^|rf 75 . dat ' 

^ ^ 'creme96 : dgrf80.dat ' , 

^ 'creme96:dgrf85.dat' , ' creme96 : igrf 90 . dat ' , 

^ ^ 'creme96:igrf90s.dat'/ 

C Remove directory path, per BB's new file open routines AJT 11/18/97 

& 'dgrf45.dat', 

& 'dgrf50.dat', 

1 'dgrf55.dat', 'dgrf60.dat', 
& 'dgrf65.dat', 

2 'dgrf70.dat', 'dgrf75.dat', 
& 'dgrf80.dat', 

3 'dgrf85.dat', 'igrf90.dat', 
& 'igrf90s.dat' / 

DATA DTEMOD / 1945., 1950., 1955., I960., 1965., 

^ 1970., 1975., 1980., 1985., 1990., 1995 / 
DATA yEAROLD/0/,IENT/0/ 
COMMON/AJTDIMO/AJTDIMO 

IF (lENT.EQ.O) THEN 
IENT=1 

write(*,*)' Initialization call to FELDCOF: YEAR = ' YEAR 
CALL INITIZE 
ENDIF 



IF (ABS ( YEAR- YEAROLD) .LT. 0.001) THEN 

DIMO=AJTDIMO 

RETURN 
ENDIF 

YEAROLD=YEAR 

c 

c numye is number of years represented by IGRF models 
c 

NUMYE=10 

C 

C IS=0 FOR SCHMIDT NORMALIZATION IS = 1 GAUSS NORMALIZATION 

C lU IS INPUT UNIT NUMBER FOR IGRF COEFFICIENT SETS 

C 

lU = 10 
IS = 0 

C-- DETERMINE IGRF-YEARS FOR INPUT- YEAR 
TIME = YEAR 
lYEA = INT(YEAR/5.)*5 
L = (lYEA - 1945) /5 + 1 
IF(L.LT,1) L=l 
IF (L.GT. NUMYE) L=NUMYE 
DTEl = DTEMOD (L) 
FILl = FILMOD(L) 
DTE2 = DTEMOD (L+1) 
FIL2 = FILM0D(L+1) 
C-- GET IGRF COEFFICIENTS FOR THE BOUNDARY YEARS 
C Error messages added by AJT 11/24/97 

CALL GETSHC (lU, FILl, NMAXl, ERAD, GHl, lER) 
IF (lER .NE. 0) THEN 

WRITE (6, 9999) FIL1,IER 
^^^^ FORMATC® 02001 ABNORMAL TERMINATION: 

& /,lx, ' IGRF Coefficient file not found: 

& /,lx,A80, 

& /,lx,' Error return code = ',lio,' STOP.') 

STOP 
ENDIF 



CALL GETSHC FIL2 , NMAX2 , ERAD, GH2 , lER)^ 

IF (lER .He. 0) THEN 

WRITE(6, 9999) FIL2, lER 
STOP 
ENDIF 

C-- DETERMINE IGRF COEFFICIEOTS FOR YEAR 
IF (L .LE. NUMYE-1) THEN 

CALL INTERSHC (YEAR, DTEl, NMAXl, GHl, DTE2 , 
1 ' NMAX2, GH2, NMAX, GHA) 

ELSE 

CALL EXTRASHC (YEAR, DTEl, NMAXl, GHl , NMAX2 , 
1 GH2, NMAX, GHA) 

ENDIF 

C-- DETERMINE MAGNETIC DIPOL MOMENT AND COEFFIECIENTS G 
FO=O.DO 
DO 1234 J=l,3 

F = GHA (J) * l.D-5 
FO = FO + F * F 
1234 CONTINUE 

DIMO = DSQRT(FO) 
AJ'TDIMO=DIMO 



GHl(l) = 0.0 
1=2 

F0=l.D-5 

IF(IS.EQ.O) FO=-FO 
SQRT2=SQRT(2.) 



DO 9 N=1,NMAX 
X = N 

FO = FO * X * X / (4. DO * X. - 2. DO) 
IF(IS.EQ.O) FO = FO * (2. DO * X - l.DO) / X 
F = FO * 0.5D0 
IF(IS.EQ.O) F = F * SQRT2 
GHKI) = GHA(I-l) * FO 
I = I+l 
DO 9 M=1,N 

F = F* (X + M) / (X-M + l.DO) 

IF(IS.EQ.O) F = F * DSQRT((X - M + l.DO) / (X+M)) 
GHl(I) = GHA(I-l) * F 
GH1(I+1) = GHA(I) * F 
1 = 1+2 
9 CONTINUE 
RETURN 
END 

C 
C 

SUBROUTINE GETSHC (lU, FSPEC, NMAX, ERAD, GH, lER) 

C Version 1.01 
C 

C Reads spherical harmonic coefficients from the specified 

C file into an array. 

C 

C Input : 

C lU - Logical unit number 

C FSPEC - File specification 

C 



c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 



Output : 
NMAX 
ERAD 



GH 
lER 



- Maximum degree and order of model 

- Earth's radius associated with the spherical 
harmonic coefficients, in the same units as 
elevation 

- Schmidt quasi -normal internal spherical 
harmonic coefficients 

- Error number: = 0, no error 

= -2, records out of order 

= FORTRAN run-time error number 



A . Zunde 

USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 



CHARACTER 
DIMENSION 
integer 



FSPEC* (*) 
GHC) 

Stat, creme96_open 



C 

C Open coefficient file. Read past first header record. 

C Read degree and order of model and Earth's radius. 

C 

C made READONLY, 5-16-96, PRB . 

C OPEN (IU,FILE=FSPEC, STATUS^'OLD' , READONLY, IOSTAT=IER, ERR= 99 9) 

Stat = creme96_open(fspec, 'cr96tables' ,iu, 'old' ) 
if (stat .ne. 0) goto 999 
READ (lU, *, IOSTAT=IER, ERR=999) 
READ (lU, *, IOSTAT=IER, ERR=999) NMAX, ERAD 



c 
c 


Read the coefficient 


file, arranged 


as follows : 




c 






N 


M 


G 


H 


c 














c 




/ 


1 


0 


GH(1) 




c 




/ 


1 


1 


GH(2) 


GH(3) 


c 




/ 


2 


0 


GH(4) 




c 




/ 


2 


1 


GH(5) 


GH(6) 


c 


NMAX* {NMAX+3)/2. 


/ 


2 


2 


GH{7) 


GH(8) 


c 


records 


\ 


3 


0 


GH(9) 




c 




\ 










c 




\ 










c 


NMAX* (NMAX+2) 


\ 










c 


elements in GH 


\ 


NMAX 


NMAX 






c 














c 


N and M are, respectively, the 


degree and order of the 


c 


coefficient. 



























1 = 0 

DO 2211 NN = 1, NMAX 

DO 2233 MM = 0, NN 

READ (lU, *, IOSTAT=IER, ERR=999) N, M, G, H 
IF (NN .NE. N .OR. MM .NE. M) THEN 
lER = -2 
GOTO 999 
ENDIF 



I = 

GH(I)^G 

IF {M .NE. 0) THEN 
1 = 1 + 1 
GH(I) = H 

ENDIF 

2233 CONTINUE 
2211 CONTINUE 

999 CLOSE (lU) 



RETURN 
END 



C 
C 



SUBROUTINE INTERSHC (DATE, DTEl, NMAXl, GHl, DTE2 , 
1 NMAX2, GH2, NMAX, GH) 



C = = = = = = = = = = = = = = === =====r = = = = = = = = = = = == = ^=^^^^^^^^^^^^^^^^^^^^^^, 

C 

C Version 1.01 
C 

C Interpolates linearly, in time, between two spherical 

C harmonic models. 
C 

C Input : 

C DATE - Date of resulting model (in decimal year) 

C DTEl - Date of earlier model 

C NMAXl - Maximum degree and order of earlier model 

C GHl - Schmidt quasi -normal internal spherical 

C harmonic coefficients of earlier model 

C DTE2 - Date of later model 

C NMAX2 - Maximum degree and order of later model 

C GH2 - Schmidt quasi -normal internal spherical 

C harmonic coefficients of later model 
C 

C Output : 

C GH 

C NMAX 
C 

C A. Zunde 

C USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 
C 

c ======================= 



Coefficients of resulting model 

Maximum degree and order of resulting model 



DIMENSION GH1(*), GH2(*), GH(*) 

C 

C The coefficients (GH) of the resulting model, at date 

C DATE, are computed by linearly interpolating between the 

C coefficients of the earlier model (GHl), at date DTEl, 

C and those of the later model (GH2) , at date DTE2 . If one 

C model is smaller than the other, the interpolation is 

C performed with the missing coefficients assumed to be 0. 



C 



FACTOR = (DATE - DTEl) / (DTE2 - DTEl) 



IF (NMAXl .EQ. NMAX2) THEN 
K = NMAXl * (NMAXl + 2) 



NMAX 

ELSE IF (NMAiJT^.GT. NMAX2) THEN 
K = NMAX2 * {NMAX2 + 2) 
L = NMAXl * (NMAXl + 2) 
DO 1122 I = K + 1, L 
1122 GH(I) = GHl(I) + FACTOR * (-GHl(I)) 

NMAX = NMAXl 

ELSE 

K = NMAXl * (NMAXl + 2) 
L = NMAX2 * (NMAX2 + 2) 
DO 1133 I = K + 1, L 
1133 GH{I) = FACTOR * GH2 (I) 

NMAX = NMAX2 
ENDIF 

DO 1144 I = 1, K 
1144 GH{I) = GHl(I) + FACTOR * (GH2{I) - GH1{I)) 



C 
C 



C 
C 
C 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 



RETURN 
END 



SUBROUTINE EXTRASHC (DATE, DTEl, NMAXl, GHl , NMAX 2 , 
1 GH2, NMAX, GH) 



Version 1 


.01 


Extrapolates linearly a spherical harmonic model with a 


rate-of -change model. 


Input : 




DATE 


- Date of resulting model (in decimal year) 


DTEl 


- Date of base model 


NMAXl 


- Maximum degree and order of base model 


GHl 


- Schmidt quasi -normal internal spherical 




harmonic coefficients of base model 


NMAX2 


- Maximum degree and order of rate-of -change 




model 


GH2 


- Schmidt quasi-normal internal spherical 




harmonic coefficients of rate-of -change model 


Output : 




GH 


- Coefficients of resulting model 


NMAX 


- Maximum degree and order of resulting model 


A . Zunde 




USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 


DIMENSION 


GHl (*) , GH2 (*) , GH(*) 



C 

C The coefficients (GH) of the resulting model, at date 

C DATE, are computed by linearly extrapolating the coef- 

C ficients of the base model (GHl), at date DTEl, using 

C those of the rate-of -change model (GH2) , at date DTE2 . If 

C one model is smaller than the other, the extrapolation is 



c 
c 



performed wit 



missing coefficients assume! 



m 



be 0. 



FACTOR = (DATE - DTEl) 



IF (NMAXl .EQ. NMAX2) THEN 
K = NMAXl * (NMAXl + 2) 
NMAX = NMAXl 

ELSE IF (NMAXl .GT. NMAX2) THEN 



K = NMAX2 * 
L = NMAXl * 
DO 1155 I = 
1155 GH(I) = 

NMAX = NMAXl 

ELSE 

K = NMAXl * 
L = NMAX2 * 
DO 1166 I = 
1166 GH(I) = 

NMAX = NMAX2 
ENDIF 



(NMAX2 
(NMAXl 
K + 1, 
GHl (I) 



(NMAXl 
(NMAX2 
K + 1, 
FACTOR 



2) 
2) 



2) 
2) 

GH2 { I ) 



1177 



DO 1177 I = 1, K 
GH(I) = GHl(I) 



+ FACTOR * GH2 (I) 



O ^ 

ni c 
c 



fi 3 



RETURN 
END 



SUBROUTINE INITIZE 



Initializes the parameters in COMMON/GENER/ 



= ATAN(l.O) *4./l80. < DEGREE >* UMR =< RADIANT > 
EARTH RADIUS FOR NORMALIZATION OF CARTESIAN 

COORDINATES (6371.2 KM) 
MAJOR HALF AXIS FOR EARTH ELLIPSOID (6378.160 
MINOR HALF AXIS FOR EARTH ELLIPSOID (6356.775 
SQUARE OF MAJOR HALF AXIS FOR EARTH ELLIPSOID 
SQUARE OF MINOR HALF AXIS FOR EARTH ELLIPSOID 



c 




c 


UMR 


c 


ERA 


c 




c 


EREQU 


c 


ERPOL 


c 


AQUAD 


c 


BQUAD 


c 





KM) 
KM) 



ERA, EREQU and ERPOL as recommended by the INTERNATIONAL 
ASTRONOMICAL UNION . 



COMMON/GENER/ 
DATA IENT/0/ 
IF (lENT.EQ.O) 

write(*, *) 

IENT=1 
ENDIF 
ERA=:6371.2 
EREQU=6378.16 
ERPOL=6356.775 
AQUAD=EREQU* EREQU 
BQUAD=ERPOL*ERPOL 
UMR=ATAN(1.0) *4./l80 
RETURN 
END 



UMR , ERA, AQUAD , BQUAD 
THEN 

Initialization call to INITIZE' 





PROGRAM SHIELD^^_DRIVER 

This is an aiixilliary program to the CREME96 software, which translates 
a user-supplied shielding distribution into a file with standard 
format and header information, as required by the CREME96 software. 
From the user inputs, supplied via interactive dialogue, this program 
produces an output file. The suggested name of this output file 
is something. SHD. (ie. the extension should be SHD.) If the file is 
given some other extension, it will not be accessible by standard 
CREME96 directory features and (in the WWW version) pull-down menus. 

IMPLICIT NONE 

CHARACTER*80 SHIELDFILE , COMMENT 
CHARACTER* 12 MATERIAL 
INTEGER*4 lUNITS , NBINS , MAXSHIELD 
PARAMETER (MAXSHIELD=500) 

REAL*4 XTHICKO (MAXSHIELD) , XPROBO (MAXSHIELD) 
REAL*4 XTHICK (MAXSHIELD) , XPROB (MAXSHIELD) 
REAL*4 XMEAN,XRMS, TOTAL 
INTEGER* 4 ERRFLAG 

INTEGER* 4 VERSION_NUMBER, PROGRAM_CODE 

CALL GET_CREME96_VERSION (VERSION_NUMBER) 
PROGRAM_C0DE=7 

CALL INISHIELD (MAXSHIELD, COMMENT, 
& lUNITS , MATERIAL, NBINS , XTHICKO , XPROBO , 

& SHIELDFILE) . 

CALL CHECK_SHIELD_DISTRIBUTION (NBINS , XTHICKO , XPROBO , 
& XTHICK, XPROB, 

& XMEAN , XRMS , TOTAL , ERRFLAG ) 

CALL OUTPUT SHIELDFILE (SHIELDFILE , 



* 



COMMENT, lUNITS , MATERIAL, 
NBINS , XTHICK, XPROB , 



* 



* 



XMEAN , XRMS , TOTAL , ERRFLAG , 
VERS I ON__NUMBER , PROGRAM CODE ) 



STOP 
END 



REAL FUNCTION 



l_HEAVY_IONS ( I Z , EN, IMODEO , ERR 



Returns the event -integrated interplanetary solar energetic heavy 
ion flixx (IZ > 2) for element 12 at energy E (in MeV/nuc) for 
SEP event LSEP. 



Inputs : 
IZ 
EN 

IMODEO 
IMODEO 
IMODEO 



Atomic number (12=3-30) 
Ene rgy { Me V/ nuc ) 

= 1: 'worst day' based on measurements of 20 OCT 89 event 
= 2: 'worst week' based on measurements of 19-26 OCT 89 events. 
= 3: peak flux, based on 5 -minute -averaged GOES protons 
on 20OCT89 



Outputs ; 



SOLAR_HEAVY_IONS = event integrated flux [in (m2-sr-MeV/nuc) **-l] 

at energy E; NOTE: NOT divided by TIME! 
ERRFLUX = its error, based on error propagation of the 

fit parameters. Not yet available. 



IMPLICIT NONE 

REAL*4 EN, ERRFLUX, FLXDUM 

INTEGER* 4 IZ , IMODEO , IMODE, lUSE, IFIT,MELM 
INTEGER* 4 NFITS , NMODE, NZ 

PARAMETER (NFITS = 2 , NM0DE=2 , NZ=2 0 , MELM=92 ) 

REAL*4 Al (NFITS, NMODE) ,A2 (NFITS , NMODE) , A3 (NFITS , NMODE) 

REAL*4 EBl (NFITS, NMODE) ,EB2 (NFITS, NMODE) 

REAL*4 BETA (NFITS, NMODE) , G (NFITS , NMODE) , GAMMA (NFITS , NMODE) 
REAL* 4 RELNORM , AVESEP , PEAKFAC , SEP_PEAK_FACTOR 
DIMENSION RELNORM (NZ) , AVESEP (MELM) 

DATA Al/ 2.3759E+06, 2.4218E+5, 2.9731E+06, 3.2764E+05 / 

DATA A2/ 4.9518E+08, 1.8991E+08, 1.1307E+09, 3.0372E+08/ 

DATA A3/ 0.106702E+10, 0. 252948E+10 , 0 . 667628E+09 , 0 . 249719E+09/ 

DATA EBl/ 4*0.0 / 

DATA EB2/ 15.94, 24.23, 12.89, 17.22/ 

DATA BETA/ 0.5601, 0.2967, 0.4372, 0.2507/ 

DATA G/ 5.7000, 5.7000, 5.7000, 5.7000/ 

DATA GAMMA/4.14060, 4.52970, 3.76850, 3.7610/ 

DATA RELNORM/5*0.0, 0.47049,0.12059, 1.00000, 0.0, 
& 0.21312, 0.0,0.20624,0.0,0.3593 5, 0.0, 

& 0.09758,0.0, 
& 0.00000, 0 . 0, 0.04826/ 

For otherwise undetermined elements Z=6-30, use relative abundances 
at 10 MeV/nuc as determined by Croley et al . from the Galileo 
data for the 240CT89 event, since these are the best available 
observations. AVESEP contains nominal abundances, relative to Fe: 

DATA AVESEP/ 5 * 0. 0, 

& 0.4263E+01, 0.1567E+01, 0.1230E+02, 0.5610E-03, 0.1915E+01, 

& 0.2146E+00, 0.3650E+01, 0.2247E+00, 0.2280E+01, 0.2804E-02, 

& 0.1252E+00, 0.2067E-02, 0.2179E-01, 0.4483E-02, 0.9506E-01, 

& 0.2929E-03, 0.4377E-02, 0.4088E-03, 0.1650E-01, 0.5625E-02, 

& O.lOOOE+01, 0.1303E-01, 0.3172E-01, 0.3048E-03, 0.7457E-03, 

For Z>30 elements, include nominal solar abundances as in old CREME. 



& 0.4878E-04, 0.1220E-03, 0.7317E-05, 0.7317E-04, 0.9756E-05, 



& 
& 
& 
& 
& 
& 
& 
& 
& 
& 
& 
& 



4878E-04, 
9756E-06, 
1463E-05, 
3415E-06, 
4878E-05, 
OOOOE+00, 
4878E-06, 
0.4878E-07, 
0.7317E-06, 
0.2195E-06, 
O.OOOOE+00, 
O.OOOOE+00, 



ci^^7E-05, 

0.4878E-05, 
0.4878E-06, 
0.7317E-05, 
0.4878E-06, 
0.2439E-06, 
0.9756E-07, 
0.1951E-06, 
0.7317E-06, 
0.2439E-05, 
O.OOOOE+00, 
0.2927E-07/ 



0.2439E-04, 
O.OOOOE+00, 
0.1707E-05, 
0. 1463E-05, 
0.1220E-05, 
0. 9756E-07, 
0.2439E-06, 
0.2195E-07, 
0.1463E-05, 
0.1463E-06, 
O..0000E+00, 



0.4878E- 
0.2195E- 
0.2195E- 
0.6585E- 
1951E- 
4878E- 
4878E- 
2439E- 
2439E- 
00O0E+ 



0.0000E+ 



M. 

05, 0. 

06, 0. 

05, 0. 

06, 0. 

06, 0. 

07, 0. 
06, 0. 
06, 0. 
00, 0. 
00, 0. 



1220E-04, 
4878E-06, 
4878E-05, 
4878E-06, 
9756E-06, 
7317E-07, 
2195E-06, 
4878E-07, 
2439E-06, 
OOOOE+00, 
4878E-07, 



SOIiAR_HEAVY_IONS = 0 . 0 

ERRFLUX=0.0 

IF (EN.LE.O.) RETURN 

IF (IZ.LE.2) RETURN 

Set mode flag: 

Note: Peak flux (IMODE0=3) is scaled from worst-day (IMODEO = 1) : 
IMODE=IMODE0 

IF (IMODE0.EQ.3) IM0DE=1 

Select baseline spectrum: 

IUSE=8 
IFIT=1 

IF (IZ.GT.20) THEN 

IUSE=26 
IFIT=2 

ENDIF 

Nominal modeling: 

IF (EN.LE.EBl (IFIT,IMODE) ) THEN 

Note: EB1=0: This segment never activated. 

FLXDUM=A1 (IFIT, IMODE) *EXP ( -BETA ( IFIT , IMODE) *EN) 
ELSEIF (EBKIFIT, IMODE) .LT. EN .and. EN. LE . EB2 { IFIT, IMODE) ) THEN 

Forced exponential roll -off at low energies 

FLXDUM=EXP(-G(IFIT, IMODE) *EN**0.25} 

FIiXDUM=A2 (IFIT, IMODE) *FLXDUM*EN**0 . 2 5 
ELSEIF (EN. GT.EB2 (IFIT, IMODE) ) THEN 

Power- law fits at high energies 

FLXDUM=A3 (IFIT, IMODE) *EN** ( -GAMMA ( IFIT, IMODE) ) 
ENDIF 

Special case of broken power-law in worst-week Fe: 

IF (IMODE. EQ. 2 .and. IUSE.EQ.26 .and. EN.GT. 127.93) THEN 

FLXDUM=3 .168141E+6*EN** (-2 .861) 
ENDIF 

Scale by relative -abundance factors to get other elements 

IF (IZ.LE.20 .and. RELNORM (12) . GT . 0 . ) THEN 

SOLAR_HEAVY_IONS = FLXDUM*RELN0RM (IZ) /RELNORM (lUSE) 

ELSE 

SOLAR_HEAVY_IONS = FLXDUM*AVESEP (12) /AVESEP (lUSE) 



ENDIF 




Finally, convert from /cm2 to /m2 : 
SOLAR_HEAVY_IONS = SOLiAR_HEAVY_IONS*l . OE+4 

For peak-flux model, scale from average: 
IF (IMODE0.EQ.3) THEN 

PEAKFAC=SEP_PEAK_FACTOR (EN) 

SOLAR__HEAVY_IONS =SOLAR_HEAVY_IONS * PEAKFAC 
ENDIF 
RETURN 
END 

REAL FUNCTION SEP_PEAK_FACTOR (EN) 

Gets relative scale factor of peak -to -average flux, based 
GOES proton observations of the 20OCT89 SEP event: 

IMPLICIT NONE 

REAL EN, ENO , ERRFLUX , SOLAR_PROTONS , AVEFLUX , PEAKFLUX 

CHARACTER*? LABEL 

ENO=EN 

IF (EN0.GT.400. ) EN0=400. 
IiABEL=' 20OCT89' 

AVEFLUX=SOLAR_PROTONS (ENO , LABEL, ERRFLUX) 
LABEL^'PEAKFLX' 

PEAKFLUX=SOLAR_PROTONS (ENO , LABEL, ERRFLUX) 
SEP_PEAK_FACTOR=0 .0 

IF (AVEFLUX. LE. 0.0. or. PEAKFLUX. LE. 0.0) RETURN 

SEP_PEAK_FACTOR=PEAKFLUX/AVEFLUX 

RETURN 

END 



fJ^^AR PROTONS (E.LSEP.ERPFLITy) 



REAL FUNCTION^KaR_PROTONS ( E , LSEP , ERRFLUX ) 
C 

C Returns the event -integrated interplanetary Solar Energetic Proton 

C fluence at energy E (in MeV) for SEP event "LSEP" and its estimated 

C error. 
C 

C Fluences are based on fits to the MEPAD integral proton channels 

C on GOES-7 and HEPAD proton channels on GOES-6. 

C 

C Inputs : 

C E = Energy (MeV/nuc) 

C LSEP = SEP event label (CHAR*7, see table below) 

C Outputs : 

C SEP_PROTONS = event integrated proton flux [in (m2-sr-MeV/nuc) **-l] 

C at energy E; NOTE: NOT divided by TIME! 
SIGFLUX = its error; nominally set to 10% 



C 
C 
C 

C This routine get fluence (differential in energy) , starting from 

C the fits to the integral rigidity spectrum. 

C 

IMPLICIT NONE 

INTEGER*4 NTERMS , NEVTS , 12 , ISEP 
PARAMETER ( NTERMS = 4 , NEVTS = 5 ) 

REAL* 4 E , ERRFLUX , COEF, DAMU, Q, AN, RIGVAL, MAGNETIC_RIGIDITY 
REAL*4 XVAL,XDUM,GG,YVAL, FACTOR 
CHARACTER*? LSEP 
INTEGER* 4 K 



DATA DAMU/931 . 5016/ 
DATA IZ/1/,Q/1.0/, AN/1.0/ 
DIMENSION COEF (NTERMS , NEVTS) 
DATA COEF/ 
C 20OCT89 

& 0.231924E+02, - 0 . 223621E+02 , 0 . 168443E+02 , - 0 . 599437E+01 
C 190CT8 9 

& 0.207522E+02, -0 . 139185E+02 , 0 . 874864E+01 , - 0 . 334163E+01 
C 220CT89 

& 0.215929E+02, - 0 . 155329E+02 , 0 . 790699E + 01 , - 0 . 258523E+01 
C 240CT89 

& 0.214273E+02, -0 . 193048E+02 , 0 . 164647E+02 , - 0 . 632318E+01 , 
C Peak fluence (/cm2-sr-s) October 1989: 

& 0.135472E+02, - 0 . 232970E+02 , 0 . 185617E+02 , -0 . 674944E+01/ 

SOLAR_PROTONS=0 . 0 
ERRFLUX=0. 0 

IF (E.LT.1.0 .OR. E.GT.l.OE+5) RETURN 
ISEP=0 

IF (LSEP.EQ. '20OCT89' ) ISEP=1 
IF (LSEP.EQ. '190CT89' ) ISEP=2 
IF (LSEP.EQ. '220CT89' ) ISEP=3 
IF (LSEP.EQ. ' 240CT89' ) ISEP=4 
IF (LSEP.EQ. 'PEAKFLX' ) ISEP=5 
IF (ISEP.EQ.O) RETURN 



RIGVAL=MAGNETIC_RIGIDITY (E, Q, AN) 

XVAL=C0EF(1, ISEP) 
XDUM=0.0 

DO 500 K=2, NTERMS 



m • 



GG= FLOAT (1 
XVAL=XVAL+COEF(K, ISEP) *RIGVAL**GG 
XDUM=XDUM+GG*COEF (K, ISEP) *RIGVAL** (GG-1 . 0) 
500 CONTINUE 

YVAL=ABS (XDUM) *EXP (XVAL) 



C Now need to calculate Jacobian to go from rigidity to kinetic 

C energy: 

FACTOR= (E+DAMU) /SQRT (E*E+2*E*DAMU) 
FACTOR=:AN* FACTOR/Q 

C 

C Additional factor comes from two sources: 

C l.OE-3 comes from GeV to MeV conversion; 

C l.OE+4 comes from /cm2 to /m2 conversion. 

C 

SOLAR_PROTONS = 10 . 0* FACTOR *YVAL 

C 

C For the peak flux mode, the fit parameters give the 5 -minute 

C averaged fluence in (cm2-sr-s) **-l . Need to remove time factor 

C to put on same basis as other fits: 

C 

IF (ISEP.EQ.5) SOLAR_PROTONS = SOLAR_PROTONS*300.0 

I F ( SOLAR_PROTONS . LT . 0 . ) SOLAR_PROTONS = 0.0 

ERRFLUX=0 . 10*SOLAR_PROTONS 

RETURN 

END 



SUBROUTINE ST ELOWER,EUPPER,M, IZLO, IZUP,TA^^) 

IMPLICIT NONE 

REAL* 4 ELOWER,EUPPER, AA, AMASS, EE, DE,STPOW 

INTEGER*4 M, IZLO, IZUP, NELM, MARR, STAT, CREME96_OPEN 

CHARACTER* 12 TARGET 

PARAMETER (MARR=5000 , NELM=:92 ) 

REAL*4 SP(NELM,MARR) ,E(MARR) 

INTEGER*4 J,K,I- 

COMMON/MASS /AMASS (109) 



Construct list of energies 

DE= (EUPPER/ELOWER) ** (1 . / (M-1 . ) ) 

E(1)=EL0WER 

DO J=2,M-1 

E(J) =E(J-1) *DE 
END DO 
E (M) =EUPPER 



OPEN(UNIT=28, STATUS='NEW' , FILE= ' USER : STABLE . DAT' ) 
Stat = creme96_open {' stable. dat 'user' ,28, 'new' ) 
WRITE (28, 100) ELOWER,EUPPER,M, IZLO, I ZUP, TARGET 
WRITE (28, 100) 
DO J=IZLO, IZUP 
AA=AMASS (J) 
DO K=1,M 
EE=E(K) 

SP{J,K) =STPOW(EE,FLOAT(J) ,AA, TARGET) *AA 
END DO 

WRITE (28, 200) (SP(J,K) ,K=1,M) 
Skip line between elements AJT 5/7/96 
WRITE (28, 200) 
END DO 

CLOSE (UNIT=28) 

F0RMAT(1X,2 (1PE10.4,2X) ,3 (I5,2X) , A12 , 2X, IPEIO . 4 ) 
FORMAT( (1X,6 (1PE10.4,2X) ) ) 



RETURN 
END 



FUNCTION STPOTWR, 20,A1,NAME) 

Q ******★★★***★************★**★*★*★★**♦**♦★**********★*★** ******* 

C * THIS ROUTINE RETURNS THE STOPPING POWER OF NUCLIDE (Z0,A1) 

C ♦IN MATERIAL 'NAME' AT El (MeV/nucleon) . 

C * DATA ON THE STOPPING MATERIAL IS CONTAINED IN TARGET.DAT. 

Q *************************************************************** 

CHARACTER*12 NAME$ { 150) , NAME, LNAME 

REAL IADJ$ (150, 28) ,NA$ (150,28) , NASPM$ (150 , 28 ) 

INTEGER*4 STAT, CREME96_OPEN 

DIMENSION NAS$ (150) ,NZ$ (150, 28) ,DENS$ (150) 
DIMENSION IGAS$ (150) ,ETAD$ (150) 
DATA ITARG,LNAME/0, 'QXZ8F3' / 

COMMON /AVG/ AVGZ , AVGZ2 , AVGA, AVGI ! MEAN STOPPING MED. PARAMETERS 
C * READ IN TARGET DATA 

IF (ITARG.EQ.l) GO TO 100 
C OPEN (UNIT=10,FILE='CREME96: TARGET. DAT' , STATUS= ' OLD' , READONLY, SHARED) 

Stat = creme96_open(' target.dat' , 'cr96tables' , 10, 'old' ) 

1 FORMAT (IX, 13) 

2 F0RMAT(1X,A12,2X,F9.6,2X,F9.6,2X, I1,2X,I2) 

3 FORMAT (IX, 13 , 2X, F8 . 4 , 2X, F5 . 1 , 2X, F9 . 5) 
READ (10,1) NM$ 

DO J1=1,NM$ 

READ (10, 2) NAME$(J1) ,DENS$(J1) ,ETAD$(J1) ,IGAS$(J1) ,NAS$(J1) 
DO J2=1,NAS$ (Jl) 

READdO, 3) NZ$ (Jl, J2) , NA$ (Jl, J2) , IADJ$ (Jl, J2) ,NASPM$ (Jl, J2) 
END DO 
END DO 
ITARG=1 
CLOSE (UNIT=:10) 
100 CONTINUE 

C * DETERMINE WHICH TARGET DATA TO USE 

IF (NAME.EQ.LNAME) GO TO 2 00 
DO J1=1,NM$ 

IF(NAME.EQ.NAME$(J1) ) K1=J1 
END DO 

LNAME=NAME$ (Kl) 

IF (NAME . NE . LNAME ) THEN 

STPOW=0. 

RETURN 
ENDIF 

C * COMPUTE MATERIAL PARAMETERS 

RHO=DENS$ (Kl) 
IGAS=IGAS$ (Kl) 
ETAD=ETAD$ (Kl) 
NTOTAL=0 
AVGZ=0 . 
AVGZ2=0. 
AVGA=0. 
AVGI=0. 

DO J1=1,NAS$ (Kl) 

NTOTAL=NTOTAL + NASPM$ (Kl , Jl) 

AVG2=AVGZ + NASPM$(K1,J1)*FL0AT(NZ$(K1,J1)) 
AVGZ2=AVGZ2 + NASPM$ (Kl , Jl) *FLOAT (NZ$ (Kl , Jl ) ) **2 
AVGA=AVGA + NASPM$ (Kl , Jl) *NA$ (Kl , Jl) 
AVGI=AVGI + NASPM$(K1, Jl) *AL0G(IADJ${K1, Jl) ) 
END DO 

AVGZ=AVGZ/FLOAT (NTOTAL) 
AVGZ2=AVGZ2 /FLOAT (NTOTAL) 



n 
O 



ai^^^WER , EUPPER , M , I ZLO , I ZUP , TARgI^^ 



SUBROUTINE STABI 
IMPLICIT NONE 
REAL*4 ELOWER, EUPPER, AA, AMASS, EE, DE,STPOW 
INTEGER*4 M, I2LO, IZUP, NELM, MARR, STAT, CREME96_0PEN 
CHARACTER* 12 TARGET 
PARAMETER (MARR=5000 , NELM=92 ) 
REAL*4 SP (NELM, MARR) ,E (MARR) 
INTEGER*4 J,K, I 
COMMON/MASS/AMASS (109) 

C Construct list of energies 

DE= (EUPPER/ELOWER) ** (1 . / (M-1 . } ) 
E(l) ^ELOWER 
DO J=2,M-1 

E(J) =E(J-1) *DE 
END DO 
E (M) =EUPPER 

C OPEN ( UNI T= 2 8, STATUS =' NEW , FILE= ' USER : STABLE . DAT' ) 

Stat = creme96_open(' stable.dat' , 'user' ,28, 'new ) 
WRITE (28, 100) ELOWER , EUPPER , M , I ZLO , IZUP , TARGET 
WRITE (28, 100) 
DO J=IZL0,I2UP 
AA=AMASS (J) 
% DO K=1,M 

EE=E(K) 

SP (J, K) =STPOW (EE , FLOAT (J) , AA, TARGET) *AA 
END DO 

WRITE(28,200) (SP ( J, K) , K=l , M) 
J*; C Skip line between elements AJT 5/7/96 

^ WRITE (28,200) 

END DO 

= CLOSE(UNIT=28) 



100 F0RMAT(1X,2 (1PE10.4,2X) ,3(I5,2X) , A12 , 2X, IPEIO . 4 ) 
200 F0RMAT( (1X,6 (1PE10.4,2X) ) ) 

RETURN 
END 



FUNCTION STE^pSll, Z0,A1,NAME) 

* THIS ROUTINE RETURNS THE STOPPING POWER OF NUCLIDE (Z0,A1) 

* IN MATERIAL 'NAME' AT El (MeV/nucleon) . 

* DATA ON THE STOPPING MATERIAL IS CONTAINED IN TARGET.DAT. 

CHARACTER*12 NAME$ (150) , NAME , LNAME 

REAL IADJ$ (150,28) ,NA$(150,28) , NASPM$ ( 150 , 28 ) 

INTEGER*4 STAT, CREME96_0PEN 

DIMENSION NAS$(150) ,NZ$(1S0,28) ,DENS$(150) 
DIMENSION IGAS$(150) ,ETAD$(150) 
DATA ITARG,LNAME/0, 'QXZ8F3' / 

COMMON /AVG/ AVGZ , AVGZ2 , AVGA, AVGI ! MEAN STOPPING MED. PARAMETERS 

* READ IN TARGET DATA 

IF (ITARG.EQ.l) GO TO 100 

OPEN (UNIT=10,FILE='CREME96: TARGET. DAT' , STATUS= ' OLD' , READONLY, SHARED) 
Stat = creme96_open(' target.dat' , 'cr96tables' ,10, 'old') 
FORMAT (IX, 13) 

F0RMAT(1X,A12,2X,F9.6,2X,F9.6,2X, I1,2X,I2) 
FORMAT (IX, I3,2X,F8.4,2X,F5.1,2X,F9.5) 
READ (10,1) NM$ 
DO J1=1,NM$ 

READ (10,2) NAME$ ( Jl ) , DENS $ ( Jl ) , ETAD$ ( Jl ) , IGAS $ ( Jl ) , NAS $ ( Jl ) 

DO J2=1,NAS$ (Jl) 

READ (10, 3) NZ$(J1,J2) ,NA$(J1, J2) , IADJ$ ( Jl , J2 ) , NASPM$ ( Jl , J2 ) 

END DO 
END DO 
ITARG=1 
CLOSE (UNIT=10) 
CONTINUE 



* DETERMINE WHICH TARGET DATA TO USE 
IF (NAME.EQ.LNAME) GO TO 200 
DO J1=1,NM$ 

IF(NAME.EQ.NAME$(J1) ) K1=J1 
END DO 

LNAME=NAME$ (Kl) 

IF (NAME.NE.LNAME) THEN 

STPOW=0. 

RETURN 
ENDIF 



* COMPUTE MATERIAL PARAMETERS 

RH0=DENS$(K1) 

IGAS = IGAS $(K1) 

ETAD=ETAD$ (Kl) 

NTOTAL=0 

AVGZ=0. 

AVG22=0. 

AVGA=0. 

AVGI=0. 

DO J1=1,NAS$ (Kl) 

NTOTAL=NTOTAL + NASPM$ (Kl , Jl) 

AVGZ=AVGZ + NASPM${K1,J1)*FL0AT(NZ$(K1,J1)) 

AVGZ2=AVGZ2 + NASPM$ (Kl, Jl) *FLOAT (NZ$ (Kl, Jl) ) ♦*2 

AVGA=AVGA + NASPM$ (Kl , Jl) *NA$ (Kl , Jl) 

AVGI=AVGI + NASPM$(K1, Jl) *ALOG(IADJ$(Kl, Jl) ) 

END DO 

AVGZ=AVGZ/FLOAT (NTOTAL) 
AVGZ2=AVGZ2 /FLOAT (NTOTAL) 



AVGA=AVGA/FM 
AVGI=EXP(AVG? 
RAT=AVGZ/AVGA 
CONTINUE 




iNTOTAL) 

'LOAT (NTOTAL) ) 




200 



C 



* COMPUTE STOPPING POWERS 



STPOW=0. 

IF (El.LE.O.) RETURN 
EPRIME=0 . 6443*Z0+13 . 7144 
XLAMBDA= (El/EPRIME) **3 .2/1.4427 
IF (XLAMBDA.GT.69. ) THEN 

WEIGHT=0 . 
ELSE 

WEIGHT=EXP ( -XLAMBDA) 
ENDIF 

DO J1=1,NAS$ (Kl) 

IF (El.GT.l.) THEN 

TH=RDEDX(E1,ZO,A1,FLOAT{NZ$(K1, Jl) ) , 

NA$ (Kl, Jl) ,IADJ$(K1,J1) ,1,1,1,1, i,RHO,IGAS,ETAD, RAT) 
ELSE 

TH=0. 

WEIGHT=1 . 
ENDIF 

IF (El. LT. 1000.) THEN 

TL=SPL0W(E1, Z0,A1, FLOAT (NZ$(K1,J1) ) ,NA$(K1, Jl) ) 
TN=SPNUC(E1,ZO,A1,FLOAT{NZ$(K1, Jl) ) ,NA$(K1, Jl) ) 

ELSE 



WEIGHT=0. 
ENDIF 

TTOTAL=TN + WEIGHT*TL + ( 1 . -WEIGHT) *TH 
STPOW=STPOW+NASPM$ (Kl, Jl) *NA$ (Kl, Jl) *TTOTAL 
END DO 

STPOW=STPOW/ (AVGA* FLOAT (NTOTAL) ) 
END 

FUNCTION RDEDX{E1,Z0,A1,Z2,A2,IADJ,I0,I1,I2,I3,I4, 
6c RHO, IGAS,ETAD,RAT) 

C AHLEN PROGRAMMED BY SALAMON, MODIFIED BY ADAMS TO 

C INCLUDE RELATIVISTIC BLOCH EFFECT. 

C CHANGES ARE OUTLINED WITH ASTERISKS. 



C THIS ROUTINE CALCULATES DE/DX USING THE BETHE EQUATION 

C WITH 3 CORRECTION TERMS, THE MOTT, BLOCH, AND LOW VELOCITY Z**3 

C TERMS. (SEE S.P. AHLEN, PRA17 , 1236 ( 1978 )) . ANY OR ALL OF THESE 

C CORRECTIONS CAN BE INCLUDED OR IGNORED, SPECIFIED BY THE 

C INDICES Il(MOTT), 12 (BLOCH) , 13 (LOW VELOCITY Z**3) . A ZERO INPUT 

C FOR A GIVEN PARAMETER ELIMINATES THAT PARTICULAR TERM IN THE 

C DE/DX CALCULATION. 

C 

C*************** ******** 

C RELATIVISTIC BLOCH CORRECTION (SEE S.P. AHLEN, PRA25 , 1856 ( 1982 ) ) 

C IS CONTROLLED BY THE PARAMETER 14 (RELATIVISTIC BLOCH) . 

C DENSITY EFFECT IS CONTROLLED BY 10 (DENSITY EFFECT) . 
C*************** ****************** 



TL=0. 
TN=0. 



C 



C 




n 



C THE SHELL CORRECT^^ ARE TAKEN FROM BARKAS AND Be!^ 

C PUBLICATION 1133 OF THE NATL ACAD SCI. THE LOW VELOCITY Z**3 CORRECTION 

C IS DERIVED FROM A FIGURE IN MCCARTHY AND JACKSON, PHYS REV B6 , 4131 (1972) 

C THE MOTT, BLOCK CORRECTIONS ARE FROM AHLEN' S PREVIOUSLY 

C REFERENCED PAPER. 
C 

C UNITS OF E1=MEV/AMU 

C ZO = ATOMIC NUMBER OF STOPPING NUCLEUS 

C Zl = EFFECTIVE CHARGE OF STOPPING NUCLEUS 

C Al = ATOMIC MASS OF STOPPING NUCLEUS 

C Z2 = ATOMIC NUMBER OF ELEMENT IN THE STOPPING MEDIUM. 

C A2 = ATOMIC MASS OF ELEMENT IN THE STOPPING MEDIUM 

C RAT=RATIO OF ELECTRONS /MOLECULE TO NUCLEONS /MOLECULE FOR DENSITY 

C EFFECT. 

C UNITS OF IADJ=EV. lADJ IS A REAL VARIABLE. 

C UNITS OF RETURNED DE/DX= (MEV/AMU) / {G/CM2 ) 
C 

C F1=STANDARD DE/DX FRONT FACTOR 

C F2=STANDARD BETHE NONRELATIVISTIC TERM WITH SHELL CORRECTIONS 

C F3=BL0CH CORRECTION TERM 

C F4=L0W VELOCITY Z**3 NONRELATIVISTIC CORRECTION FACTOR 

C F5=M0TT CORRECTION TERM {Z**3 TO Z**7) 

C F6 = STANDARD BETHE RELATIVISTIC TERM 

C F7=RELATIVISTIC BLOCH CORRECTION TERM 

C . 

C RHO=DENSITY OF MATERIAL, G/CM**3 (FOR A GAS, GIVE STANDARD DENSITY) 
C IGAS = 0 IF CONDENSED PHASE, 1 IF GAS . 

C ETAD=FOR GAS, DENSITY RELATIVE TO STANDARD (1 ATM, 0 DEG CENT) . MUST BE >0 
C 

COMMON/FLOOK/Fl , F2 , F3 , F4 , F5 , F6 , F7 , Zl 
REAL lADJ 

DIMENSION VA(4) ,V2FVA(4) ,Z1ABA(14) ,C0SXA(14) 

DATA 21ABA,COSXA/0.0, 0.05,0.1,0.15,0.20,0.30,0.4, 0.5,0.6, 
C 0.8,1.0,1.2,1.5,2.0,1.000,0.9905,0.9631,0.9208,0.8680, 
C 0.7478,0.6303,0.5290,0.4471, 0.3323,0.2610, 
C 0.2145, 0.1696, 0.1261/ 

DATA VA,V2FVA/1. ,2. ,3. ,4. ,0.33,0.30,0.26,0.23/ 

PI=3. 14159265 

ALPHA=1 . /137 . 03604 

G=1.+E1/931.5016 
C******** *************** 

C IF 10=0, ELIMINATE DENSITY EFFECT. 
DELT=0. 

IF(IO.EQ.O) GO TO 19 
DELT=DELTA (G, Z2 , A2 , lADJ, RHO, IGAS , ETAD, RAT) 
19 CONTINUE 
C*************** ******** 

BSQ=1.-1./G**2 
B=SQRT(BSQ) 

C***************************** ***** ******** 
Z1 = Z0 

TEST=B/ZO** (2./3. ) 




IF (TEST .GT. .ll^^TO 1000 
Z1=Z0* (1. -EXP(-130. *B/ZO** (2 . /3. ) ) ) 
1000 ETA=B*G 

C* ★****♦♦*♦** *♦********★*♦*♦**** 

EMASS=0 . 5110034E+06 
F1=0.3070722*Z1**2*Z2/ (BSQ*A2) 
ETAM2=:1 . /ETA**2 

CADJ=1.0E-06*IADJ**2*ETAM2* (0 . 422377+ETAM2* (0 . 0304043-ETAM2* 

1 0.00038106) ) +1.0E-09*IADJ**3*ETAM2* (3 . 858019+ETAM2* ( -0 . 1667989 

2 +ETAM2*0. 00157955) ) 

F2=AL0G (2 . *EMASS*BSQ/IADJ} -CADJ/Z2 

F6=2.*ALOG(G) -BSQ 

F3=0.0 

F4=1.0 

F5=0.0 

C******* ******************* 

F7=0.0 

C* ******** **************************************^^ + ^^^^^^^^^^^^^^^^^^^^ 

C IF 12=0, DO NOT CALCULATE BLOCK CORRECTION. 

IF(I2.EQ. 0)GO TO 60 
Y=Z1*ALPHA/B 
Y2=Y**2 

MSUM=INT(5.*Y)+1 
SUMR=0. 

DO 90 N=1,MSUM 

FN=FLOAT{N) 

FN2=FN**2 

90 SUMR=SUMR+(1./ (FN2+Y2) -1./FN2) /FN 
F3=-Y2* (1.202+SUMR) 

C 

C IF 13=0, DO NOT CALCULATE LOW VELOCITY CORRECTION. 
60 IF(I3.EQ.0)GO TO 50 

V=ETA/ { ALPHA* SQRT (Z2) ) 

IF{V.GE.4 . )G0 TO 25 

DO 10 1=1,3 

IF(V.GE.VA{I+1) )G0 TO 10 

V2FV=V2FVA{I) + (V-VA(I) ) * {V2FVA(I+1) -V2FVA{I) ) 

GO TO 30 
10 CONTINUE 
25 V2FV=0 . 45/SQRT (V) 

30 F4=1.+2.*Z1*V2FV/ (V**2*SQRT (Z2 ) ) 
C 

C IF 11=0, DO NOT CALCULATE MOTT CORRECTION. 
50 IF(I1.EQ.O)GO TO 70 

Z1A=Z1*ALPHA 

Z1AB=ABS(Z1A/B) 

COSX=0 . 

DO 40 1=1,13 

IF(Z1AB.GE.Z1ABA(I+1) )G0 TO 40 

COSX=COSXA(I) + (ZIAB-ZIABA(I) ) * (C0SXA(I+1) -COSXA(I) ) / 
C (Z1ABA(I+1) -ZIABA(I) ) 
40 CONTINUE 

F5=0 . 5*Z1A* (B* (1 . 725+0 . 52*PI*COSX) +Z1A* (3 .246-0 . 451*BSQ 

1 +Z1A* (1 . 522*B+0 . 987/B+ZlA* (4 . 569- 0 . 494*BSQ-2 . 696 /BSQ 

2 +Z1A* (1.254*B+0.222/B-1.170/BSQ/B) ) ) ) ) 

IF(Z1AB.LE.100. *ALPHA)GO TO 70 
C************************************^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 

ERR=ZlAB**9/6. 

IF{ERR .GT. .01)ERR=.01 

IF(ERR.LT.ABS (F5/ (F2*F4+F3+F5+F6-DELT/2. ) ) )G0 TO 70 



C IF 14 = 0, DO NOT CALCXnATE RELATIVISTIC BLOCH CORRECTION. 
70 IF(I4 .EQ.0)GOTO 80 

F7=CR(21,G,B) 
80 RDEDX=F1* ( F2*F4+F3+F5+F6+F7 -DELT/2 . ) /Al 

RETURN 
END 



FUNCTION DELTA (G, 22, A2,FIADJ,RH0, IGAS , ETA, RAT) 
C THIS FUNCTION IS USED BY RDEDX . 
C 

C THIS CORRECTION FOR THE DENSITY EFFECT IS BASED ON STERNHEIMER AND 
C PEIERLS, PHYS REV B3 , 3681 (1971). 
C SET IGAS = 0 OR 1, ETA > 0 REQUIRED. 

C RHO IS DENSITY IN G/CM**3 . FOR A GAS, GIVE RHO AT T=0 DEGREES 
C CENTIGRADE, 1 ATM PRESSURE, AND THE FACTOR ETA WHICH GIVES THE 
C ACTUAL GAS DENSITY UPON MULTIPLICATION BY RHO. 
IF(G.GE.1,8)G0 TO 10 
DELTA=0. 
RETURN 

I C ************************************************************** 
; 10 PLASMA=28.8*SQRT{RHO*RAT) ! RAT REPLACES Z2/A2 FOR MOLECULE 

CBAR=2 . *ALOG (FIADJ/PLASMA) +1 . 0 
B=SQRT(1. -l./G**2) 
Y=2 . *ALOG (B*G) +IGAS*ALOG (ETA) 
IF(IGAS.EQ.1)G0 TO 100 
IF(FIADJ.GE.100. )G0 TO 20 
Yl=9.212 

y IF(CBAR.GE.3.681)GO TO 11 

Y0=0.9212 
GO TO 200 
0 11 Y0=1.502*CBAR-4.606 
GO TO 200 

20 Yl = 13.82 
IF(CBAR.GE.5.215)GO TO 21 
Y0=0. 9212 
GO TO 200 

21 Y0=1 . 502*CBAR-6 . 909 
GO TO 200 

100 IF(CBAR.GE.12.25)GO TO 110 
Yl=18.42 

IF(CBAR.LT.12 .25) Y0=9.212 
IF(CBAR.LT.11.5) Y0=8.751 
IF(CBAR.LT.ll. 0) Y0=8 .291 
IF(CBAR.LT.10.5) Y0=7.830 
IF(CBAR.LT.IO.O) Y0=7.370 
GO TO 200 
110 Yl=23.03 

IF(CBAR.GE.13 .804)GO TO 120 
Y0=9.212 
GO TO 200 
120 Y0=1.502*CBAR-11.52 
200 A=(CBAR-Y0)/(Y1-Y0) ♦*3 



IF(Y.GT.Y0)GO 
DELTA=0. 
RETURN 

210 IF(y.GE.Yl)GO TO 220 

DELTA=Y-CBAR+A* (Yl-Y) **3 

RETURN 
220 DELTA=Y-CBAR 

RETURN 

END 




FUNCTION SIGMA (NU) 
C ************* ************************************************ 

C ** THIS FUNCTION COMPUTES THE PHASE OF THE GAMMA FUNCTION OF 

C ** 1 + i*NU. IT IS CALLED BY THE FUNCTION CR WHICH COMPUTES 

C ** THE RELATIVISTIC BLOCK CORRECTION. 

C ************************* *****★★*★**★★**★* *********** 

REAL*4 NU 

DIMENSION A(7) ,H{7) 

DATA (A (I) , 1=1,5) 7.26356,1.4134, 3. 59642, 7. 0858, 12. 6408/ 

DATA (H (I) ,1 = 1, 5)/. 521756, .398667, .075942, . 003612 , 23E- 6/ 

SUM=0. 

DO 1 1=1,5 

SUM=SUM+H(I) *SIN(NU*ALOG{A(I) ) ) 

1 CONTINUE 
DEM=0, 

DO 2 1=1,5 

DEM=DEM+H ( I ) *COS (NU* ALOG ( A ( I ) ) ) 

2 CONTINUE 
SIGMA=ATAN2 (SUM, DEM) 
RETURN 

END 

FUNCTION CR(Z, GAMMA, BETA) 
C ************************************************************** 
C ** THIS FUNCTION COMPUTES THE RELATIVISTIC BLOCK 

C ** CORRECTION TO THE STOPPING POWER ACCORDING TO THE WORK 

C ** OF S.P. AHLEN, PRA25,1856 (1982). 

C ************************************************************** 

REAL*4 LAMBDA, NU, IL1,LNR0W,LNR0WT 

DATA EULER/ . 577215665/ , PI/3 . 14159265/ 

DATA AMU/931. 5016/, ALPHA/. 0072973504/ 

DATA LAMBDA/1. 0/,THETA/0.l/ 
C DEFINITIONS 

NU= Z * ALPHA/BETA 

TNU=2 . *NU 

DEM=1 . / (1 . +TNU*TNU) 
TNLT=TNU*ALOG ( 0 . 5*THETA) 
TNT=TNU*THETA 
TODEM=THETA*DEM 
C COMPUTE REAL AND IMAGINARY PARTS OF LI 
RL1=T0DEM* (SIN{TNLT) -TNU*COS (TNLT) ) 
IL1=-T0DEM* (COS (TNLT) +TNU* SIN (TNLT) ) 
AOBGL=ALPHA/ (BETA*G7U^IMA* LAMBDA) 
TNLOG=TNU*ALOG (AOBGL) 



COEFF=A0BGL*! 

ARG=TNIiOG+2 . *SIGMA(NU) 
C Bug here discovered by Bonnie Colborn 7-7-95 

C RL1=RL1+C0EF* (TNU*COS (ARC) -SIN (ARC) ) 

C IL1 = IL1+C0EF* {TNU*SIN(ARG) +COS (ARG) ) 

RL1=RL1+C0EFF* {TNU*COS (ARG) -SIN (ARG) ) 

IL1 = IL1+C0EFF* (TNU*SIN(ARG) +COS (ARG) ) 
C COMPUTE REAL PART OF L2 

FNL0G=2 . *TNU*DEM-TNLT 

FNOLOG= (TNU*TNU-1) *DEM+ALOG ( 0 . 5*THETA) 
RL2=T0DEM* (FNIiOG*COS (TNLT) +FNOLOG*SIN (TNLT) ) 
LNROW=ALOG (2 . /AOBGL) +EULER- 1+ ( 1 -TNU*TNU) *DEM 
LNROWT=ALOG (2 . /AOBGL) +EULER- 1+2 *DEM 

RL2=RL2+COEFF* (LNROW*SIN (ARG) -TNU*LNROWT*COS (ARG) ) 
C COMPUTE CR 

PINU=PI*NU 

CR=0 . 5*PINU*BETA*BETA* (PINU*EXP (PINU) /SINH (PINU) ) 
CR=CR* (2 . *TNU*ALOG (2 . } *RL1+ (PINU-1 . ) *IL1+TNU*RL2 ) 
RETURN 
END 



FUNCTION HYDRGN(EN,Z2,A2) 

Q *************************************************************** 

□ C * STOPPING POWER OF SLOW PROTONS (1 KeV to 1 MeV) 

tpi C *************************************************************** 

Q INTEGER*4 STAT, CREME96_OPEN 

^ DIMENSION A (92, 12) 

si DATA MARKER/ 0/ 

L5" IZ2 = INT(Z2+0.2) 

r1 IF (Z2.GT.92.) IZ2=92 

c *************************************************************** 

" G * ON FIRST CALL TO FUNCTION (MARKER=0) READ IN DATA FROM 

' C * PROTON.DAT. 

7^ C *************************************************************** 

IF (MARKER. EQ.O) THEN 
^ C OPEN (UNIT=50, READONLY, STATUS=' OLD' , FILE= ' CREME96 : PROTON . DAT' , SHARED) 

=^ Stat = creTne96_open( 'proton.dat' , 'cr96 tables' ,50, 'old' ) 

13 DO 1 = 1,92 

H READ(50,20) (A ( I , J) , J=l , 11 ) 

20 FORMATdl (1X,E10.4) ) 

END DO 

CLOSE (UNIT=50) 
MARKER=1 
ENDIF 

E=EN*1. 007825*1000. ! CHANGE FROM MEV/NUCLEON TO KEV 
C ************************************************************** 

C * COMPUTE STOPPING POWER IN (MEV/NUCLEON) / (G/CM**2 ) 

C ************************************************************** 

IF (E.LE.O.) THEN 
HYDRGN=:0. 
RETURN 

ELSE IF (E.LT.IOOO.) THEN 
SL=A(IZ2,1}*E**.45 

SH= (A(IZ2,2) /E)*ALOG(l.+A(IZ2, 3) /E+A(IZ2,4) *E} 
S=SL*SH/ (SL+SH) 
ELSE 

G=1.+EN/931.5016 
BSQR=(1.-1./(G*G)) 
COEFF=A ( IZ2 , 5 ) / (BSQR) 



SHELL=ALO<^H|lZ2 ,6) *BSQR/ (1 . -BSQR) ) -BSQR 
ALOGE = ALOG^^ 
SHELL=SHELL- (A { IZ2 , 7) +A ( IZ2 , 8 ) * (ALOGE) ) 

SHELL=SHELL- (A(IZ2, 9) * ( (ALOGE) **2 . ) +A(IZ2 , 10) * ( (ALOGE) **3 ) ) 
SHELL=SHELL- (A(IZ2, 11) * ( (ALOGE) **4 . ) ) 
S=COEFF*SHELL 
ENDIF 

HYDRGN=S*1. E- 21/ (A2*l. 007825*1. 659828E-24) 
IF (Z2.GT.92.) HYDRGN=HYDRGN* {Z2**2/92.**2) 
RETURN 
END 



FUNCTION HELIUM (EN, Z2,A2) 

******************************^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 

* STOPPING POWER OF SLOW ALPHAS (1 KEV TO 1 MEV) 

INTEGER* 4 STAT, CREME96_OPEN 
DIMENSION A (92, 9) 
DATA MARKER/ 0/ 
IZ2=INT(Z2+0.2) 

IF (Z2.GT.92.) IZ2=92 
******* 

* ON FIRST CALL TO FUNCTION (MARKER=0) READ IN DATA FROM 

* HELIUM.DAT. 

*********** ****************^^^^^^^^^^^^^^^^^^^^^^^^^^^.^^^^^^^^^ 
IF (MARKER. EQ. 0) THEN 

OPEN (UNIT=4 0, READONLY, STATUS=' OLD' ,FILE='CREME96 : HELIUM. DAT' , SHARED) 
Stat = creme96_open( 'helium.dat' , 'cr96tables' ,40, 'old' ) 
DO 1=1,92 

READ (40, 20) (A (I, J) , J=l,9) 
F0RMAT(9 (1X,E10.4) ) 
READ(40,20) (A ( I , J) , J=l , 9) 
FORMAT (IX, 9 (E9.4) ) 
END DO 

CLOSE (UNIT=4 0) 
MARKER=1 
ENDIF 

E=EN*4. 0026*1000. ! CHANGE FROM MEV/NUCLEON TO KEV 
*********************^,*^,*^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 

* COMPUTE STOPPING POWER IN (MEV/NUCLEON) / (G /CM* *2 ) 
*********************^*^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 

IF (E.LE.O.) THEN 
HELIUM=0. 
RETURN 

C CHANGE IN UPPER ENERGY LEVEL, R.A. WITT 17 MARCH 1994 
C ELSE IF (E.LT. 10000. ) THEN 

ELSE IF (E.LT. 100000. ) THEN 
SL=A(IZ2, 1) *E**A(IZ2,2) 

SH=(A(IZ2,3)/(E/1000.))*ALOG(1.+A(IZ2,4)/(E/1000 )+A(IZ2 5) 
& *(E/1000.)) 

S= (SL*SH/ (SL+SH) ) 

ELSE 

EE=ALOG (1/ (E/1000 . ) ) 

S=EXP (A(IZ2, 6) +A(IZ2, 7) *EE+A(IZ2, 8) *EE*EE+A ( IZ2 , 9) *EE*EE*EE) 
ENDIF 




HELIUM=S*1.E-^^A2*4 . 0026*1 . 659828E-24 ) 
IF (Z2.GT.92.) HELIUM=HELIUM* (Z2**2/92. **2) 
RETURN 



END 



FUNCTION SPLOW(E, Z0,A1, Z2, A2) 

***************************************************^^* 
* STOPPING POWER OF SLOW NUCLEI 

IZl=INT(Z0+0.2) 

IF (IZl.EQ.l) THEN 

SPLOW=HYDRGN(E, Z2, A2) *1 . 007825/Al 
ELSE IF (IZ1.EQ.2) THEN 

SPLOW=HELIUM(E, Z2,A2) *4 . 0026/Al 
ELSE 

C=2. 99792458E10 

V=C* {1 . - (1 . / (E*1.6022E-6/C/l .673E-24/C+1 . ) ) **2 . ) **0 
Vl = 0.886* (V/2 .188E8) *Z0** (-2 ./3 . ) 
V2=Vl+0 . 0378*SIN(V1*3 . 14159265/2 . ) 

SCALE=(1.- (1. 034-0. 1777*EXP(-0.08114*Z0) )*EXP(-V2) ) 
SPLOW=SCALE*Z0**2*HYDRGN{E, Z2,A2) *1. 007825/Al 

ENDIF 

RETURN 

END 



FUNCTION SPNUC(E,Z0,A1, Z2,A2) 

* LNS STOPPING POWER AS PROGRAMMED BY JR LETAW 
****** 

DATA ZE,A0,EC/4 .803242E-10, 5.2917706E-9, 1 .6021892E-6/ 
DATA AV,PI,XL/6.022045E23, 3.1415927, 1.309/ 
DATA T1/4.005473E-11/ ! MIN. E = 25 eV 
SPNUC=0. 

IF { (E*A1) .LT.2.5E-5) RETURN 
Z=(Z0**(2./3. )+Z2**{2./3.) ) **1.5 
A=0.8853*A0/Z** (1./3 . ) 
EL=Z0*Z2* (ZE**2/A) * (A1+A2) /A2 
G=4 . *A1*A2/ {A1+A2) **2 
ECONV=E*Al*EC 

Pl= (2. *XL) ** (1./3. ) * (EC0NV*T1/EL**2/G) ** (2 . /9. ) 

P2= (2 . *XL) ** (1 . /3 . ) * (ECONV/EL) ** (4 . /9 . ) 

FACT=1 . 125*PI*A**2* (EL**2*G/EC0NV) * {AV/A2) /Al/EC 

P1S=SQRT(1. +P1**2) 

P2S=SQRT(1.+P2**2) 

SPNUC=ALOG(P2+P2S) -P2/P2S 

SPNUC=FACT* (SPNUC- (ALOG (Pl+PlS) -Pl/PlS) ) 

RETURN 

END 



lELD (ELOWER, EUPPER, M, IZLO, IZl^jj^G 



SUBROUTINE THI^^IELD ( ELOWER , EUPPER , M , I ZLO , I ZiS^RrGET , 

& PATH, FLUX) 



C Special version of UPROPI, for doing transport through thin shield 

C without utilizing external files of dE/dx and range-energy, as generally 

C done in the UPROP routines. 

C 

C Important variables 
C 

C E Energy at each grid point after shielding 

C S Stopping power at each grid point after shielding 

C R Range at each grid point after shielding 

C EP Energy at each grid point prior to shielding 

C SP Stopping power at each grid point prior to shielding 

C RP Range at each energy EP 

C 



IMPLICIT NONE 
INTEGER*4 MARR,NELM 
PARAMETER (MARR=5000 , NELM=92 ) 
REAL*4 FLUX (NELM, MARR) , E (MARR) , FLUX2 (MARR) 
REAL*4 R (MARR) , S (MARR) , EP (MARR) , RP (MARR) , SP (MARR) 
O CHARACTER* 12 TARGET 

^ INTEGER*4 M, IZLO, IZUP, J, K, L, KK, LMAX 

Q REAL*4 ELOWER, EUPPER, PATH, REL,FUL,DE,XK, AMASS, Z, A 

□ REAL* 4 STPOW 

fy COMMON/MASS/AMASS (109) 

;4 DATA LMAX/2/ 

Lil 

^ C Compute vector of energies 

REL=1. /ELOWER 
^'j FUL=1 . /LOG (EUPPER/ELOWER) 

DE= (EUPPER/ELOWER) ** ( 1 . /FLOAT (M- 1 ) ) 

E(1)=EL0WER 
^ DO J=2,M-1 

fl E{J)=E(J-1)*DE 
-J END DO 

E (M) =EUPPER 

C Compute range-energy relations and stopping powers: 

DO J=IZLO,IZUP 



Z=FLOAT(J) 
A^AMASS (J) 

CALL RANGE (E,M, Z, A, TARGET, R) 
DO K=1,M 

S{K)=STPOW(E(K) ,Z, A, TARGET) 
END DO 
DO K=1,M 

DO KK=K,M 

IF (R(KK) .GE.R(K) +PATH) GOTO 300 
END DO 
KK=M 

EP (K) =E (KK) - (R (KK) -R (K) -PATH) *S (KK) 
R(K) =R(K)+PATH 
END DO 



Iterate LMAX times to improve estimate of EP 



DO L=1,LMAX 

CALL RANGE {EP,M, 2, A, TARGET, RP) 
DO K=1,M 

SP (K) =STPOW (EP (K) , Z , A, TARGET) 

EP (K) =EP (K) - (RP (K) -R (K) ) *SP (K) 
END DO 
END DO 

Now get flux values at these corresponding external energies 
DO K=1,M 

XK=1 . + (M- 1 . ) ♦LOG (EP (K) *REL) *FUL 

KK=INT(XK) 

IF (XK.GE.M) THEN 

FLUX2 (K) = ( (EP (K) -E (M-1) ) *FLUX { J, M) + 

{E(M) -EP(K) ) *FLUX(J,M-1) ) / (E (M) -E{M-1) ) 

ELSE 

FLUX2 (K) = ( (EP (K) -E (KK) ) *FLUX (J, KK+1 ) + 

(E(KK+1) -EP(K) )*FLUX{J,KK) )/(E(KK+l) -E(KK) ) 

ENDIF 

FLUX2 (K) =FLUX2 (K) *SP (K) /S (K) 
IF (FLUX2 (K) .LT.l.E-20) FLUX2(K)=0. 
END DO 

DO K=1,M 

FLUX (J, K) =FLUX2 (K) 
END DO 



END DO 
RETURN 
END 



PROGRAM TRANS 



DRIVER 




IMPLICIT NONE 

CHARACTER*80 INFILE, OUTFILE, SHIELDFILE 
CHARACTER* 12 TARGET 
INTEGER* 4 MARR,NELM 

INTEGER*4 VERS ION_NUMBER , PROGRAM_CODE 
PARAMETER {MARR=:5000 , NELM=92 ) 

REAL*4 INPUT_FLUX (NELM, MARR) , OUTPUT_FLUX (NELM, MARR) 
REAL* 4 ELOWER , EUPPER , UPATH 
INTEGER*4 M, IZLO, IZUP , IPATH 



Get parameters of transport calculation: 

CALL INIPROP ( INFILE, I PATH , UPATH , TARGET , SHIELDFILE , OUTFILE) 

Unload input particle flux file into array: 

CALL UNLOAD_CREME96_FLUX (INFILE, 

ELOWER , EUPPER , M , I ZLO , I ZUP , 
INPUT FLUX) 



Now do transport calculation: 

CALL CREME96_TRANSPORT ( INPUT_FLUX , 
* ELOWER , EUPPER , M , I ZLO , I ZUP , 

& I PATH, UPATH, TARGET, SHIELDFILE, 

6c VERS ION_NUMBER , PROGRAM_CODE , 

& OUTPUT FLUX) 



Now write transported flux to output file: 

CALL OLTTPUT_TRANSPORTED_FLUX (IZLO, IZUP, ELOWER, EUPPER, 



* 



I PATH , UPATH , TARGET , 
SHIELDFILE, INFILE, 
VERS ION_NUMBER , PROGRAM_CODE , 
M , OUTPUT_FLUX , OUTFILE ) 



* 



STOP 
END 



subroutine trapped_j>rotons (B, L, yearp, jmod, energy, flux, ne) 

c Inputs : 

c B from Blccoords 

c L from Blccoords 

c yearp from Blccoords 

c jmod, = 1 for solar min model, = 2 for solar max model 

c energy, an array of values in MeV 

c ne, the number of energy values in the energy array 

c Outputs : 

c flux, ne values of integral flux greater than the corresponding 

c Mev value in the energy array 

implicit none 
save 

real*4 aSmax, aSmin, B, energy, flux, L, yearp, fi, fii 

integer*4 ie, ifirst, itpfile, jmod, jmodold, ISmin, I8max 

integer*4 ne, map 

dimension energy (l) , flux(l) i 

real* 8 gmagmo 

common /gmagmo/ gmagmo ! for esa traraln 

common /energy/ f 1 (30 , 45) , f il (30 , 8) 
common /sumry/ map (777) 
common/ap8min/a8min{8) , 18min (16583) 
common/ap8max/a 8max ( 8 ) , 1 8max (16583) 

integer CREME96_OPEN, stat 
data ifirst /O/ 
data itpfile /8/ 

if (ifirst .eq. 0 ) then 
ifirst = 1 

jmodold = jmod !jmod =1 for min =2 for max 

if (jmod .It. 1 .or. jmod .gt. 2) stop 'tp_modell' 

Stat = creme96_open('ap8maxmi.inp' , 'cr96tables' , itpfile, 
^ 'old') • ' . 

c read in the proton model data to be used 

call modint (itpfile, a8min,l8min) 
read(itpf ile, 16) 

call modint (itpfile, a8max,18max) 
16 format (19a4) 

close (unit=itpf ile) 
endif 



500 continue 

if (jmod .ne. jmodold) then 

type *, ' Model number input has changed ' 
stop 'tp_model2' 

endif 



if ({b.eq. 0.) .or. (L.eq. 0.)) return !not in range of values 
if ( L .gt.ll.) return ! not in range of values 

if (jmod .eq. 1) then 

cal 1 t rara 1 ( a8min , 1 8min , L , B , energy , f lux , ne ) 
elseif (jmod .eq. 2) then 

call traral (aSmax, I8max, L, B, energy, f lux, ne) 



else 




# 



type *, ' Iiregal model number input to trapped__protons ' 
stop ' tp_model3 ' 
endif 

do ie = 1, ne 

flux(ie) =10. **flux(ie) 

if (flux{ie) .It. 1.001) flux(ie) = 0. 



subroutine modint { junit , descr, list) 

implicit none 
save 

dimension descr(8), list(16583) 
real *4 descr, dumd 

integer*4 junit, list, length, ic, Int, i, jc 
integer*4 k, kl, k2 , lb, lp,lpp 

equivalence (length, dumd) 

read (junit , 1000, end=30) (descr (i) ,i=l,7) , length, lb, ic 
descr (8) = dumd 

type 1002, {descr{i),i = 1 , 7) , length, lb, ic 
Int = length+1 
Ip = lnt/7 
Ipp = lp*7 

if (Ipp.ne.lnt) Ip = Ip+l 
Ip = lp+1 
kl = 1 

do j c = 2 , Ip 
k2 = kl+6 

read (junit, 1001, end=30) {list(k) ,k=kl,k2) ,lb,ic 

kl = k2+l 
enddo 
return 

30 type*, ' *** read eof on ', junit,' ***' 
stop 'modint' 

1000 format (2a4, 2x, 5f 10 . 3 , ilO, a4 , i4 ) 

1001 format (7il0,a4, i4) 

1002 format (Ix, 2a4, 2x, 5f 10 . 3 , ilO , 2x, a4 , i4 ) 
end 

subroutine traral (descr, map, fl, babs, e, f, n) 
C* ********************************************************************* 
C B / BO CASE JOEL STEIN 9-15-71 X2133 KMS 

C TRARAl DOES ENERGY VALUE SETUiCH FOR FLUX CALCULATION WHEN GIVEN A 
C B AND L POINT. 

* Modified version based on Kluge and Lenhart ESOC Int. Note 78 (1971) 



enddo 

return 

end 



* 



Modified 



APRIL 1988 E.J. DALY ESA/ESTEC/WMA 



* 



can pick up geomagnetic dipole moment GMAGMO 
from common block and use it in place of 
Mcllwain's value of .311653 
GMAGMO is passed from the geomagnetic 
coordinate program. 

Default for models should be Mcllwain's value 



* 



* 



* 



• % 

* Modified JULY 1993 H.D.R. EVANS ESA/ESTEC/WMA 

* Kluge and Lenhart interpolation method in 

* (B/BO,L) space changed to a linear polygon 

* interpolation method in (Phi,L) space. 

C MAP(l) is the first word of list 

C S0,S1,S2 are logical variables which indicate whether the flux for a 
C particular E,B,L point has already been found in a previous call 
C to TRARAP. 

implicit none 
save 

logical s0,sl,s2 

real*4 bobO, babs, descr, e, eO, el, e2 , f, fl, fo, fl, f2 
real*4 trarap 

integer*4 ie, io, il, i2, i3, 13, map, nb, n, nl 

dimension e (1) , f (1) , descr (8) , map (1) 
real* 8 gmagmo 
common / gmagmo / gmagmo 

nl=aminl (32766. , abs {fl*descr (5) ) ) 
MAX B/BO ALLOWED HERE IS 1000 (PROTECT AGAINST INTEGER OVERFLOW) 

if (gmagmo .le. 0.) gmagmo = 0.311653 

BOB0= AMINK (BABS* (FL*FL*FL) / GMAGMO ), 1000.) 
bobO = (babs* (fl*fl*fl) / gmagmo ) 
if (bobO .gt. 1000.) bobO = 1000. 

HANDLE CASE WHERE B/BO IS LESS THAN 1.0 (DISREGARDING REPRESENTATIONAL 
errors) 

if ( bobO .It. 0.95) then 
do ie = 1, n 

f (ie) = -99.0 ! CHECK TO SEE IF -99 IS USED IN CALLING ROUTINE?????? 
enddo 
return 
endif 

FORCE ANY POSSIBLE REPRESENTATIONAL ERRORS TO 1 . 0 
BoBO = AMAXK BoBO, 1.0) 

nb = abs((bobO-l) * descr (6)) 
C NL IS THE MINIMUM OF THE L VALUE OR 15.999, SCALED TO AN INTEGER BY 
C THE L SCALING FACTOR 

C NB IS THE DIFFERENCE BETWEEN THE INPUT B VALUE AND B EQUATORIAL, 
C SCALED TO AN INTEGER BY THE B SCALING FACTOR. 

11 = 0 

12 = map(l) 

13 = i2+map(i2+l) 
13 = map(i3+l) 

el = map{il+2) /descr (4) 
e2 = map(i2+2)/descr (4) 
si = .true. 
s2 = .true. 



12 IS THE NUMBER OF ELEMENTS IN THE FLUX MAP FOR THE FIRST ENERGY. 

13 IS THE INDEX OF THE LAST ELEMENT OF THE SECOND ENERGY MAP. 
L3 IS THE LENGTH OF THE MAP FOR THE THIRD ENERGY. 

El IS THE ENERGY OF THE FIRST ENERGY MAP (UNSCALED) 
E2 IS THE ENERGY OF THE SECOND ENERGY MAP (UNSCALED) 

SI AND S2 ARE TRUE TO INDICATE THAT NO FLUXES HAVE YET BEEN FOUND, 
do 3 ie = l,n 

THE DO STATEMENT LOOPS THROUGH THE ENERGIES FOR WHICH FLUXES ARE 
DESIRED AT THE GIVEN B,L POINT {BABS,FL) . 

if (e(ie) . le . e2 .or . 13 . eq. 0) goto2 



THE IF STATEMENT CHECKS TO SEE IF THE INPUT ENERGY IS LESS THAN OR E 
THE ENERGY OF THE SECOND MAP, OR IF THE LENGTH OF THE THIRD MAP IS 
(I.E. THERE ARE NO HIGHER ENERGIES IN THE TABLE) . IF TRUE, USE TH 
FOR THOSE TWO ENERGY MAPS TO FIND THE DESIRED FLUX AT THE DESIRED 
ENERGY. IF FALSE, THE ZEROTH ENERGY MAP IS DEFINED TO BE TNE FIRS 
ENERGY MAP, THE FIRST BECOMES THE SECOND, AND THE SECOND BECOMES 
THE THIRD. E0,E1,E2 ARE THE ENERGIES FOR THE ZEROTH , FIRST , AND SEC 
ENERGY MAPS. F0,F1,F2 ARE THE FLUXES FOR THE ZEROTH, FIRST, AND 
SECOND ENERGY MAPS AT THE B,L POINT. 

10 = il 

11 = ±2 
±2 = i3 

i3 = i3+l3 
13 = map(i3+l) 
eO = el 
el = e2 

e2 = map(i2+2) /descr (4) 

sO = si 

si = s2 

s2 = . true . 

fO = fl 

fl = f2 

gotol 

if (sl)fl = trarap (descr, map (il+l) , fl,bobO) 
if {s2)f2 = trarap (descr, map (i2+l) , fl,bobO) 
THESE TWO LOGICAL IFS CALL TRARAP FOR THE FLUX FROM THE FIRST AND 
SECOND ENERGY MAPS AT THE B,L POINT IF THEY HAVE NOT ALREADY BEEN 

51 = .false. 

52 = .FALSE. 

SI AND S2 ARE FALSE SINCE Fl AND F2 ARE NOW FOUND. 
f(ie) = fl+(f2-fl)*(e(ie)-el)/(e2-el) 

INTERPOLATE FOR THE FLUX F(IE) USING THE FLUXES AND ENERGIES FOR MAP 
ONE AND TWO. 

THE FOLLOWING COMMENTS APPLY TO THE REMAINING PROGRAM STATEMENTS. 

IF THE FLUX F2 FOR THE SECOND ENERGY MAP IS GREATER THAN ZERO, OR TH 
ZEROTH ENERGY MAP HAS NOT BEEN DEFINED, THE FINAL FLUX IS THE MAXI 
OF THE INTEROOLATED FLUX OR ZERO. IF THE FLUX FOR THE SECOND ENER 
MAP IS EQUAL TO ZERO, AND THE ZEROTH ENERGY MAP HAS BEEN DEFINED, 
THEN INTERPOLATE FOR THE FLUX USING THE ZEROTH AND FIRST ENERGY MA 
CHOOSE THE MINIMUM OF THE TWO INTERPOLATIONS, AND THEN THE MAXIMUM 
CHOICE AND ZERO FOR THE FINAL FLUX VALUE. 



if (f2 .gt .0. )goto3 
if {il.eq.0)goto3 

if(sO)fO = trarap (descr ,map (iO+1) , f 1 , bobO) 
sO = .false. 

f(ie) = aminKf (ie) ,fO+(fl-fO)*(e(ie)-eO)/{el-eO)) 

f{ie) ^ amaxl (f (ie) , 0. ) 

return 

end 



*************************************************************** 

REAL FUNCTION TRARAP ( HEADER, MAP, L, BoBO) 
********************************************************* 

PURPOSE: This function converts the B argument to a hybrid 

value, defined by Phi = ASIN( { B - BO) / (Bmax- BO)) 
and interpolates the MAP in (PHI-L) space. 

METHOD: The conversion to the Phi-L space requires the 

maximum B value. This is obtained by interpolating 
between the maximum B values for the L strings 
that subtend the L value passed to the routine. 

The Flux at the Phi point along the two L strings 
is determined by locating the three model points 
that form a polygon (triangle) that contains the 
(L,Phi) point. The interpolation is then performed 
by a linear interpolation using the slope of the 
plane in (L,Phi,lnF) space. 

HISTORY: CREATED July 1993 H.D.R. Evans ESA/ESTEC/WMA 

********************************************************* 

implicit none 
save 

real bobO, 1, b, phi 



integer*4 map(*) 

real header (*) 

real model (3, 100, 2) 

real Is (100), bs(lOO), fluxes (100) 

real bm(2) , bo 

real verts (3, 3) 

real reqpt (3) 

real xphi, bO , xinter, bmax, interp 
integer *4 estrng, Istrng 

integer*4 lpos(2), lien, blen(2), li 

integer*4 i/ j 

integer*4 s(2), n(2), string, other, tmp 

logical found, endstr 

logical inpoly 



if ( bobO .It. 1.0 ) then 

trarap = 0.0 

return 
endif 



b = bobO * 0.311653 / (1**3) !????ASK TONY: SHOULD WE USE GMAGMO? 

call lvals{ map, header. Is, lien) 

FIND THE TWO L STRINGS THAT SUBTEND THE L VALUE WE ARE GIVEN. . . 
do li = 1, llen-2 

if ( 1 .le. ls(li+l) ) go to 6 
enddo 
continue 




C GET THE MAXIMUM B VALUES FOR THE TWO L STRINGS. ALLOWS US TO 

C LINEARLY INTERPOLATE TO FIND THE MAXIMUM B VALUE FOR THE GIVEN 

C L VALUE. 



do i = 1, 2 

Ipos(i) = lstrng( map, header, ls(li+i-l), lien) + 1 
call bvals ( map { Ipos(i)), header, bs, fluxes, blen(i)) 
bm(i) = bs{blen(i) ) 
bo = bO { ls{li+i-l) ) 
if (bo .gt.O.) then 
do j=l, blen(i) 

model {l,j,i) = ls{li+i-l) 

model{2,j,i) = xphi ( bs(j)/bo , bm(i) / bo ) 
model(3,j,i) = fluxes{j) 
enddo 
else 

blend) = 1 

model (l,l,i) = ls(li+i-l) 
model(2,l,i) = -1.0 
model (3, 1, i). = 0.0 
endif 
enddo 



bo = b0( 1) 

phi = xphi ( b / bo, xinter ( 1, Is(li), bm(l) , 
& Is (li+1) , bm{2) ) / bo 



O C CHECK FOR AN INVALID PHI VALUE, E.G. IF B > BMAX . 

bj if ( phi .It. 0 ) then 

trarap =0.0 
^ return 
1^ endif 

i!l C IF LENGTH OF BOTH STRINGS IS 1, THEN LINEAR INTERPOLATION BETWEEN 



C POINTS AND RETURN 

if { blen(l) .eq. 1 .and. blen(2) .eq. 1) then 

trarap = ( 1 - model (1 , 1 , 1) ) * 

& ( model (3, 1,2) - model (3, 1,1) ) 

& ( model (1,1, 2) - model (1,1,1) ) 
if (trarap .gt.O) trarap = ( trarap) 
return 
endif 



C NOW FIND H VALUES IN BOTH L STRINGS THAT SUBTEND REQUIRED POINT. 



reqpt(l) = 1 
reqpt (2) = phi 
s(l) = 1 
s(2) = 1 

n(l) = min( s(l)+l, blen(l)) 
n(2) = min( s(2)+l, blen(2)) 



10 continue 

endstr = ( s(l) .eq. blen(l)) .and. ( s(2) .eq. blen(2)) 
if (.not. endstr) then 

if ( s(l) .eq. blen(l) ) then ! string 1 is empty, have to use string 2 now. 
string = 2 



other = 1 

else if ( s (2) . eq.blen (2) ) then ! string 2 is empty, have to use string l. 

string=l 

other =2 
else 

if ( model ( 2, n{l), 1) .It. model (2, n{2),2) ) then 

string = 1 

other = 2 
else 

string = 2 

other = 1 
endif 
endif 

found = inpoly( model (1, s (string) , string), 
& model (1, s (other) , other) , 

& modeld, n (string) , string) , reqpt ) 

if ( .not. found ) then 

s( string ) = n( string) 

n( string) = min( n (string) +1, blen( string) ) 
endif 

endif 

if (.not. (found. or. endstr) ) goto 10 

C REPEAT THIS UNTIL END OF BOTH STRINGS OR POLY FOUND 

C NOW CHECK FOR END OF STRING CONDITION, REQUIRES BACKING UP AND 

C USING A PREVIOUS POINT. 

if ( endstr) then 

if (blen(l) .eq. 1) then 

string = 2 

other = 1 
else if (blen(2) .eq. 1) then 

string = 1 

other = 2 

else if (model (2 , s (string) -1, string) .It. 
& model (2 , s (other) -1, other) ) 

& then 

tmp = other 
other = string 
string= tmp 
endif 

n (string) =s (string) -1 
endif 

do j=l,3 

verts (j,l) = model (j, 
verts (j, 2) = model (j, 
verts(j,3) = model (j, 
enddo 

trarap = interp ( verts, reqpt) 
if (trarap .gt. 0) trarap = ( trarap) 

998 continue 
return 
end 




s (string) , string) 
s (other) , other) 
n (string), string) 



******************** ************************* * 

real function interp { gpnts, reqpnt) 
Q*** ********************* *★*★★***★* ********************* 

C PURPOSE: Interpolates between 3 points in 3D space. 
C 

C METHOD: Constructs function of a plane containing the 3 points 

C and calculates the Z value for the given {X,Y) point. 
C 

C HISTORY: CREATED July 1993 H.D.R. Evans 

c****************** ****************************** *********************** 

implicit none 
save 



real*4 gpnts { 3, *) 

real*4 reqpnt { 3) 

real*4 vl (3) , v2 (3) 

real*4 rv(3) 

real*4 plane (4) 

real*4 rvl, rv2 , scl 

real*4 dotp, disl2 

integer*4 i 



Interp = 0.0 
C COMPUTE VECTORS IN PLANE OF THREE POINTS. 

a 

yj do i=i,3 

□ vl( i) = gpnts (i, 2) - gpnts (i, 1 ) 

□ v2( i) = gpnts (i, 3) - gpnts (i, 1 ) 



enddo 



Ijj C DETERMINE NORMAL TO PLANE DEFINED BY VI AND V2 , AND PLANE 

C CONSTANT. PLANE{1)X + PLANE(2)Y + PLANE(3)Z = PLANE(4) 

call CrossP( vl, v2 , plane, 3) 

plane(4) = DotP(3, GPnts(l,l), 1, plane, 1) 

I . I 

^2 C VALUE WE REQUIRE IS THE Z VALUE AT THE POINT SPECIFIED 

^ C BY THE SOLUTION OF: 

^ C Z = (PLANE (4) - PLANE {1)X - PLANE (2) Y ) / PLANE (3) 

IF (Plane (3) .NE. 0) THEN 

Interp = (Plane (4) - Plane (1) * ReqPnt(l) 
& - Plane (2) * ReqPnt(2) ) / Plane (3) 

else 

print* , 'plane containing 3 given points is independent of z' 
print* plane = plane , char (7) 
stop 
endif 



return 
end 

(2*********************************************************************** 

subroutine crossp{ x, y, z, dim) 
C********************** ******************************* ****************** 

C PURPOSE: " Takes the cross product of the two vectors. 

C 

C METHOD: Basic vector calculations. Vectors must be the 

C same size. 

C 



July 1993 H.D.R. Evan^^i 



C HISTORY: CREATEI^ July 1993 H.D.R. Evan^SSA/ESTEC/WMA 

Q* ********************* ****************************** 

implicit none 
save 

C X - 1ST VECTOR 

C Y - 2ND VECTOR 

C Z - CROSSPRODUCT = X^Y 

C DIM - DIMENSION OF X, Y AND 2 

real*4 x{*) , y(*) , z(*) * 
real*4 magz 

integer*4 dim 

integer*4 i, j, indx 

indx (j) = mod( j + dim - 1, dim) + 1 

do i=l, dim 
magz = 0 

z{i) = x(indx(i+l)) * y(indx(i+2)) - 
5c x(indx(i+2)) * y(indx(i+l)) 

enddo 
return 
end 

n 

^ c*********************************************************************** 

real*4 function dotp ( n, sx, incx, sy, incy ) 
t=? c*********************************************************************** 

Q C PURPOSE: Returns the inner (dot) product of SX and SY. 

rlJ c 

O C METHOD: Basic vector calculations. Vectors must be the 

uJ C same size. 

M= c 

s C HISTORY: CREATED July 1993 H.D.R. Evans ESA/ESTEC/WMA 

L=5- c***** ********************************************************** ******** 

fy implicit none 

1,1 save 

Vs.* 

integer *4 n, incx, incy 
[f- real*4 sx(*) , sy (*) 

integer*4 i, pos 

pos(i,incx) = (i-l) *incx + 1 
dotp = 0 
do i=l,n 

dotp = dotp + sx (pos (i, incx) ) * sy (pos (i, incy) ) 
enddo 
return 
end 

C* **************************************************************** ****** 

logical function inpoly{ a, b, c, pt) 
C* ********************************************************************** 

C PURPOSE: Returns .TRUE, if the (X,Y) coordinates of point Pt 
C is in the polygon described by the points A,B,and C 

C 

C METHOD: Pts is decomposed into the sum of the line segments 

C AC and BC, i.e. PTS = a * AC + b * BC. If either a 

C or b is less than zero, then PTS is not subtended by 

C the lines AC & BC. 

C 

C This is then repeated for the AB and CB line segements 



C to end" 

C 

C HISTORY: CREATED 

C 

**********************! 

implicit none 
save 

real*4 a{2), b(2), c(2), pt(2) 

real*4 det 

real*4 m (2,2), im(2,2) 

real*4 u(2), v(2), po(2), coeff(2) 

integer*4 i 

do i=:l,2 ! initialise the matrix 

m(l,i) = a{i) - c(i) 

m(2,i) = b(i) - c(i) 

pod) = pt(i) - c(i) 
enddo 



PTS isn't the other side of AB line from C. 

July 1993 H.D.R. Evans ESA/ESTEC/WMA 



det = m(l,l) * m(2,2) - m(l,2) * m(2,l) 
if ( det .eq. 0 ) goto 999 



im(l, 1) = m(2, 2) 

im{2,2) = m(l,l) 

im(l,2) = - m(2,l) 

im{2,l) = - m(l,2) 



coef f (1) 
coeff (2) 
inpoly = 



(im{l,l) 
(im(2,l) 
coeff (1) 



* pod) 

* pod) 



+ im(l,2) * po(2) ) /det 
+ im(2,2) * po{2) ) /det 
0.0 .and. coeff (2) .ge. 0. 



0) 



REPEAT THE PREVIOUS, ONLY THIS TIME WITH THE END POINT. 

do i=l,2 

m(l,i) = bd) - ad) 
m(2,i) = cd) - ad) 
pod) = pt(i) - a(i) 
enddo 

det = m(l,l) * m(2,2) - m(l,2) * m(2,l) 
if ( det .eq. 0 ) goto 999 



im(l,l) = 
im{2,2) = 
im{l,2) = 
im{2,l) = 
coeff (1) 
coeff (2) 
inpoly = 

return 



m(2,2) 
m(l,l) 

- m(2,l) 

- m(l,2) 
= (imd,l) 
= (im(2,l) 
( coeff (1) 



* pod) 

* pod) 
.ge 



+ imd,2) 
+ im{2,2) 
0.0 .and. coeff (2) 



* po(2) ) /det 

* po(2) ) /det 



.ge. 0.0) 



. and . inpoly 



999 continue 

inpoly = .false, 
print* , char (7) 

stop ' ***inpoly*** determinant = 0' 
end 

C**** ********** ***************************** 

real*4 function xinter ( x, xl, yl, x2 , y2) 

c purpose: linearly interpolates between (xl,yl) and (x2,y2) . 




C 

c method: simple linear interpolation, 

c 

c history: created july 1993 h.d.r. evans esa/estec/wma 

c** ************************************************** ^ 

implicit none 
save 

real*4 x, xl, x2, yl, y2 

if { x2 .ne. xl ) then 

xinter = yl + (x- xl) * (y2-yl) / (x2-xl) 
else 

xinter = yl 
endif 

return 
end 

integer*4 function estrng( map, header, e, len) 

c 

C RETURNS INDEX IN THE AX8 MAP WHERE REQUESTED ENERGY STRING STARTS, 

c***** ********************* *********************** ********** 

implicit none 
save 

real*4 e 

real*4 header (*), energy 

integer*4 index, len 

integer*4 map{*) 

integer*4 epos, escl, maplen 

data epos, escl, maplen / 1, 4, 8/ 

c len : length of current energy string 

c epos : offset in the energy string of the energy 

c maplen: position in the header of the total map length 

c escl : position in the header of the energy scale factor 



index = 1 
'"-4 energy = 0 

10 if ( (e . le . energy) .or. (index .gt. header (maplen) ) ) goto 2 0 
len = map ( index) 

energy = 1.0 * map ( index + epos) / header (escl) 

if ( e .gt. energy) index = index + len 
goto 10 
20 continue 

estrng = index 

return 

end 

C****** ************************************************************** *** 

integer*4 function Istrng ( estr, header, 1, len) 
C************************* ***************************************** *****c 
C Returns the index in the Energy string (ESTR) 

C that the requested L string starts . 

Q********** ********************************************************** *** 
implicit none 
save 

real*4 1 

real*4 header (*) 



"-4 



real* 4 mapl 
integer*4 index, len 
integer*4 estr(*) 
integer*4 slen, Ipos, Iscl 

data slen, Ipos, Iscl / 1, 1, 5 / 

c slen - position in the e string of the e string length 

c Ipos - offset in the 1 string of the 1 value 

c Iscl - position in the header of the 1 scale factor 

c index = position of the first 1 string in the e string 

index = 3 

mapl = 0 

if ( 1 .eq. 0 ) then 

Istrng = index - 1 

return 
endif 

10 if ( (l.le.mapl) .or. (index .gt. estr(slen) ) ) goto 20 
len = estr( index) 

mapl = estr( index + Ipos) / header ( Iscl) 
if (1 .gt. mapl) index = index + len 
goto 10 
20 continue 

Istrng = index - 1 

return 

end 

C******** ***************************************** ********** 

subroutine evals ( map, header, e, npts) 
St ******************************************************************** * 

C Searches through the Ax8 model for all of the energies it contains. 

(;;*********************************************************************** 

implicit none 
save 

real*4 header {*) 

real*4 e(*) 

integer* 4 map(*) 

integer*4 npts, index 

integer*4 epos, escl, maplen 

data epos, escl, maplen / 1, 4, 8/ 



C EPOS 
C ESCL 
C MAPLEN 



OFFSET IN THE ENERGY STRING OF THE ENERGY 
POSITION IN THE HEADER OF THE ENERGY SCALE FACTOR 
POSITION IN THE HEADER OF THE TOTAL MAP LENGTH 



index = 1 
npts = 0 

10 continue 

npts = npts + 1 

e{npts) = map{ index +1) / header ( escl) 
index - index + map (index) 
if ( index .le. header (maplen) .and. map (index) .ne. 0) go to 10 

return 
end 

1************ ************************************************** ********* 



{^^str, header, 1, npts) 



siibroutine lvals{^^str, header, 1, npts) 

C Searches through Energy string for all of the L values it contains. 

C*************** ************************************** ************ 

integer*4 estr(*) 

real * 4 header ( * ) 

real*4 1(*) 

integer*4 npts 

C SLEN - POSITION IN THE E STRING OF THE E STRING LENGTH 

C LPOS - OFFSET IN THE L STRING OF THE L VALUE 

C LSCL - POSITION IN THE HEADER OF THE L SCALE FACTOR 



integer*4 slen, Ipos, Iscl 

data slen, Ipos, Iscl / 1, 1, 5 / 



index = 3 

npts = 0 0 

10 if { index .ge. estr(slen) ) goto 20 
npts = npts + 1 

1 (npts) = estr ( index + Ipos) / header ( Iscl) 
index = index + estr ( index) 
goto 10 
2 0 continue 
Q return 
S end 

Q C* ********************************************************* *********** 
Q subroutine bbOval ( Istr, header, bobO, Influx, npts) 

fs ! C************ ****************************************************** ***** 

Q C Returns the BoBo and LoglO(flux) values contained in the L string 
us C (MAP) 

I \ c** **************************************************************** ***** 
implicit none 
save 

k:j integer*4 lstr(*) 

real*4 header (*) 

real*4 bobO(*) 
real*4 lnflux(*), i 

integer*4 npts 
integer*4 len 

integer*4 slen, bscl, flxscl, flxinc, flxoff 
data slen, bscl, flxscl, flxinc, flxoff 
& / 1, 6, 7, -256, 3 / 



C SLEN - POSITION IN THE B STRING OF THE B STRING LENGTH 

C LPOS - OFFSET IN THE L STRING OF THE L VALUE 

C LSCL - POSITION IN THE HEADER OF THE L SCALE FACTOR 

C FLXSCL - POSITION IN THE HEADER OF THE LNFLUX SCALE FACTOR 

C FLXINC - UNSCALED INCREMENT IN B BETWEEN STRING VALUES 

C FLXOFF - OFFSET IN B STRING OF THE BO LNFLUX VALUE 



npts = 1 

len = lstr( slen) 

bobO(l) = 1.0 

Influx (1) = lstr( flxoff) / header (flxscl) 
if { len .It. 4) return 

npts = 0 
i = 4 

10 if ( (i.gt.len) .or. (lstr{i).le. 0) ) goto 20 



npts = npts + 
lnflux(i-2) = (lstr(flxoff ) + f Ixinc* (i-f Ixof f ) ) / 
& header (flxscl) 

bob0(i-2) = bobO (i-f Ixof f) + Istr (i) /header (bscl) 
i = i + 1 
goto 10 
2 0 continue 
return 
end 




Q********************** ****************** ********** ******* 

subroutine bvals ( Istr, header, b, Influx, npts) 
C************ ******************************************************* **** 

c Returns B and Logl0{flux) values contained in L string (MAP) 

Q* ******************************************************* *************** 

implicit none 
save 

real*4 header(*), b(*) 

real*4 lnflux(*), bobO(40) 

real*4 1, bo, bO 

integer*4 lstr(*) 
integer*4 npts, i 

integer*4 Ipos, Iscl 
p data Ipos, Iscl / 2, 5/ 

Q C LPOS - POSITION IN L STRING OF THE L VALUE 

p C LSCL - POSITION IN THE HEADER OF THE L SCALE FACTOR 

g 1 = Istr (Ipos) / header ( Iscl) 

ri call bbOval ( Istr, header, bobO, Influx, npts) 

bo = bO( 1) 

do i = 1, npts 

b{i) = bobO(i) * bo 

if ( b(i) .eq. 0) Influx(i) ^ 0.0 
enddo 
return 

z 

'J (;;*********************************************************************** 

subroutine phival ( Istr, header, 1, phi, Influx, npts) 
(2*********************************************************************** 

C Returns Hybrid and LoglO(flux) values contained in L string (MAP) 

C********* **************************************************** ********** 



IS! 



implicit 


none 


save 




real*4 


bm, bO (100) , bmax 


real*4 


header (*) 


real*4 


1 


real*4 


Influx (*) 


real*4 


phi{*) 


real*4 


xphi 


integer*4 


i 


integer*4 


Istr (*) 


integer*4 


npts 


call bbOval ( 


Istr, header, bO, Influx, ; 


CONVERT THE 


B VALUES TO THE HYBRID ONES 


bm = bo ( npts) 


do 10 i = 1, 


npts 


phi(i) = 


xphi ( bO (i) , bm) 



L^^) Influx (i) 



if ( phi(i) .ICT^) Influx (i) =0.0 
10 continue 
return 
end 

C***** ************************************************* ******** 

real*4 function xphi { bobO, bmax) 
C* ********************************************************************* ****** 
c Computes the hybrid magnetic field coordinate= 
C { B/BO - 1 ) 

C XPHI= ASIN( ) 

C ( Bmax/BO - 1 ) 

C Where Bmax is the atmospheric cutoff value for B. 
C If Bmax = 1, then XPHI =90. ( Arcsin( 1.0) ) 

C* ****************************************************************** ********* 
implicit none 
save 

real*4 bobO, bmax 
real*4 sine 



if ( bobO .gt. bmax) then 

C ARCSIN( >1.0) BOBO BEYOND THE ATMOSPHERIC CUT OFF. 

xphi = -1.0 
return 
endif 

if { bmax .ne. 1) then 

sine = (bobO - l)/(bmax-l) 

if ( (-l.le. sine) .and. (sine .le.l.O) ) then 
xphi = asin{ sine ) * 180.0 / 3.1415927 

else 

xphi = -1.0 

endif 
else 

xphi = -1.0 
endif 
return 
end 

Qi,icic****ic****ic*** ******************** **ic*** 

real*4 function bO(l) 
************************************ ******************* 

C computes magnetic field strength for an L shell at magnetic equator. 

C******** ********************************************************** ******* 

implicit none 
save 

real*4 1 

if ( 1 .gt. 0 ) then 

bO = 0.311653 / (1*1*1) ! ????ASK TONY: SHOULWE USE GMAGMO? 

else 

bO = 0 
endif 
return 
end 



PROGRAM Trapped_^^Cton_Driver 



IMPLICIT NONE 

SAVE ! f rom original DRIVER supplied by Colborn & Armstrong 

integer*4 ie, iemax, ifile, igo, imod, ne, ns, Mpts 

parameter (iemax = 30) ! MAX NO. OF ENERGIES ALLOWED 
real Evals (iemax) 

INTEGER NLvals 
PARAMETER (NLvals =10) 

INTEGER Ndays ! program now calculates this from period and Norbits. 
INTEGER Norbits, Norbsteps larguments to subroutine calls, 11-26-97. 

REAL OrbPrecTime ! f or future use, 11-26-97. 

REAL TrappedFlux (lEmax, NLvals) , XLbounds (NLvals) 
REAL RelDwellTime (NLvals) 
REAL Year 

REAL Diff TrappedFlux (lEmax, NLvals) 

INTEGER MARR 
PARAMETER (MARR=5000) 

REAL Eout (MARR) , Fluxout (MARR, NLvals) 

REAL Orblncl , Apogee , Perigee , AscNodeLong , AscNodeDisp , PerigDisp 

INTEGER ILbins 
CHARACTER*80 TrappedFile 

INTEGER Program_Code 
DATA Program_Code/l/ 

INTEGER IpreCalc 

LOGICAL DistBelt,PreCalcFlux 

REAL ELOWER,EUPPER 

DATA ELOWER, EUPPER/l . OE-01 , 1 . OE+05/ 
REAL OrbPeriod . 



CALL TrappedDriverlnput (Evals , NE, Orblncl , Apogee, Perigee, 

# AscNodeLong , AscNodeDisp , PerigDisp , TrappedFile , Year , 

# XLbounds, ILbins, imod, DistBelt , PreCalcFlux, IPreCalc, 

# Ndays , Norbits , Norbsteps) 

CALL Trapped_ORBINT( Orblncl, Apogee, Perigee , AscNodeLong, 

# AscNodeDisp, PerigDisp, Evals , NE, TrappedFlux, 

# Diff TrappedFlux, Year , XLbounds , ILbins , imod, RelDwellTime , 

# DistBelt , PreCalcFlux, IPreCalc, 

# Ndays , Norbits , Norbsteps , OrbPeriod, OrbPrecTime) 

CALL Trapped_Spectra (Evals, NE, ELOWER, EUPPER, Mpts, ILbins, 

# TrappedFlux , Diff TrappedFlux , Eout , Fluxout ) 



CALL OutputTrappedFlux (Evals , NE, TrappedFlux, Diff TrappedFlux, 



F'^^^Orblncl , Apogee , Perigee , AscNoc^^^» 



# TrappedF^^^Orblncl, Apogee, Perigee, As cNoderohg, 

# AscNodeDisp , PerigDisp , Year , XLbounds , ILbins , PROGRAM_CODE , 

# imod, RelDwellTime, DistBelt , PreCalcFlux, IPreCalc, 

# BLOWER , EUPPER , Mp t s , Eout , Fluxou t , 

# Ndays , Norbits , Norbsteps , OrbPeriod, OrbPrecTime) 

STOP 
END 

********* icitirir*iriririr**ie******-k****i(*ir* it ******* 

subroutine differ (ne, e, fa, fb, d, Ilbins) 
c******************** ************** ******************* 

implicit none 
save 

real* 4 da, db 

integer*4 i, j, ne, ILbins, L 

INTEGER iemax,NLvals 

PARAMETER (iemax = 30 , NLvals=10) 

C make array fixed size, so that don't have difficulties with 2D 
C array allignment. 

REAL*4 e (iemax) , fa (iemax, NLvals) 

REAL* 4 fb (iemax, NLvals) , d (iemax, NLvals) 

c routine finds d(i) the differential flux at energy e(i) 

c assuming that the spectrum is best represented by an exponential 

c 

c ne is number of energies 

c fa(i) is integral flux above e(i) ^ 

c fa(ne) is defined by routine 

c fb(i) is the flux between e(i+l) and e(i) 



do L = 1 , ILbins 

do i = ne , 1 , - 1 

if (fa(i,L) .gt. 0) go to 2 

d(i,L) = 1 .Oe-37 
enddo 
GOTO 99 

if (i .eq. ne) i = i-1 
fa(i+l,L) = fa(i,L) - fb(i,L) 
if (fa(i+l,L) .ne. 0) go to 6 
i = i-1 

if (i .gt. 1) go to 6 
d(l,L) = fa{l,L)/(e(2)-e(l)) 
GOTO 99 

db = -alog{fa{2,L)/fa(l,L))/(e(2)-e(l))*fa{l,L) 
do j = 1 , i 

da = -alog(fa(j+l,L)/fa(j,L))/(e(j+l)-e(j))*fa(j,L) 
Added error checking on da*db, 11-24-97. 

IF (da*db .GE. 0.0) THEN !da*db should be >= 0 for physical solutions 

d( j ,L) = sqrt (da*db) 
ELSE 



d(j,L) = 0 
ENDIF 

db = da*fa(j+l,L) /fa(j,L) 
enddo 

d{i+l,L) = da*fa{i+l,L) /fa(i,L) ! for protons 
99 CONTINUE ! for going to next L-value bin instead of return 
enddo ! stepping through L-bins . 
return 
end 

c**************** *************************** ****** 

SUBROUTINE TrappedDriver Input {Evals,NE, Orblncl, Apogee, Perigee, 

# AscNodeLong, AscNodeDisp, PerigDisp, TrappedFile, 

# Year , XLbounds , ILbinsum , imod , 

# DistBelt, PreCalcFlux, IPreCalc, 

# Ndays , Norbits , Norbsteps , OrbPrecTime) 

IMPLICIT NONE 

REAL Orblncl, Apogee, Perigee, AscNodeLong, AscNodeDisp, PerigDisp 

C Note that the eccentricity is calculated here to decide if 

Q C need to read PerigDisp. The eccentricity is also recalculated 

uf! C in the initialization CALL 0RBIT(1,...) case. 

S C This makes the input driver independent of the actual computational 

^Ts C routines, so that it will be easier to modify and interface with other 

C space environment routines . 

uJ 

REAL E,Re ! eccentricity and radius of Earth 

PARAMETER (Re=6371.2) 
7 REAL ApPerSwitch 

nJ INTEGER IERR,IACCEPT 

UJ DATA IERR/0/ 

INTEGER Ndays 

SI INTEGER* Norbits, Norbsteps !now passed as arguments, 11-26-97. 

REAL OrbPrecTime ! f or future use, 11-26-97. 
CHARACTER* 80 TrappedFile 

INTEGER NLvals, I,L, ILbinMax, ILbinsum, imod 
PARAMETER (NLvals=10) 

REAL XLbounds (NLvals) , XLinf inite , Year , YearMin, YearMax 
PARAMETER (XLinf inite=l . OE+06 ) 

C Appropriate epochs for AP8MIN & AP8MAX L-value calculations 

PARAMETER (Yearmin=1964 . 0 , Yearmax=1970 .0) 

REAL XLdummy 

INTEGER iemax 

parameter (iemax =30) ! MAX NO. OF ENERGIES ALLOWED 
real evals (iemax) 
integer ne 



define energy grid for test case 

energy values often used in space station calculation 

These are hardwired into calculation for now. 

Changed E to Evals {since E is the now the eccentricity) 

INTEGER IpreCalc, IFLUXtype 
LOGICAL DistBelt,PreCalcFlux 

INTEGER Idummy ! For diagnostic message on number of I/O parameters. 



NE = 


29 






EVALS 


(1) = 




1.0 


EVALS 


(2) = 




2.0 


EVALS 


(3) = 
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50. 
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= 
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150. 
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(23) 
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l.OE+05 



WRITE (6, 1000) 
WRITE (6, 1001) 

initialize boundaries L-value bins 

XLbounds (1) =0 . 0 

DO L=2,NLvals 

XLbounds (L) =XLinf inite 
ENDDO 

9390 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE(*,390) 

IFLUXtype=0 

READ {* , * , ERR=9390, IOSTAT=IERR) IFLUXtype ! installed, 11-26-97 . 
PreCalcFlux= . FALSE . ! initialize not to use pre-calculated Flux 



! hardwired off for now. 
DistBelt= .FALSE. ! hardwire off for now. 
IpreCalc=0 

IF (IFLUXtype .NE. 0) THEN 
93 91 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE{*,391) 

READ(*, *,ERR=93 91, IOSTAT=IERR) IpreCalc 
PreCalcFlux= . TRUE . 

DistBelt= . FALSE . lhardwire off for now, since we do not include a 

! "disturbed belt" model 

C Use quiet- time, 51.6 degrees as the default case. 

IF (IpreCalc .LT. 0 .OR. IpreCalc .GT. 3) IpreCalc=0 

9427 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE {*, 427) 

READ ( * , 42 8 , ERR=9427 , IOSTAT=IERR) TrappedFile 
CALL CHECK_OUTPUT_FILE (TrappedFile , lACCEPT) 
IF (lACCEPT.NE.O) GOTO 9427 

Q C The SUBROUTINE OutputTrappedFlux presently takes these variables 

i£l C from the header information in the pre-calculated files, 

g C IMOD is also taken from that header information. Only IpreCalc 

r=i C is re-checked against that header information. 12-1-97. 

J=2 CF? IF (IpreCalc .EQ. 0 .OR. IpreCalc .EQ. 1) THEN 

CF? OrbIncl=51.6 

rf CF? Apogee=400.0 

^ CF? Perigee=400 . 0 

CF? ELSEIF (IpreCalc .EQ. 2 .OR. IpreCalc .EQ. 3) THEN 

iT; CF? OrbIncl=28.5 

CF? Apogee=450.0 

j=y CF? Perigee=450 . 0 

H= CF? ENDIF 

Nl C The pre-calculated fluxes are not available (and not divided into 

C L-bins) 

ILbinsum=l 

RETURN 

ENDIF 

C Moved the questions and answers on AP8MIN or AP8r4AX here, 12-11-97. 

9454 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(*,454) 

READ {*, *,ERR=9454, IOSTAT=IERR) imod 

IF (imod .LT. 0 .OR. imod .GT. 1) imod=0 

imod = imod + 1 I model no. for subroutine blccoords 

! model no. for subroutine trapped__protons 



IF (imod .EQ. 1) YEAR=1964.0 
IF (imod .EQ.. 2) YEAR=1970.0 



C End of moved questions & answers on AP8MIN or AP8MAX, 12-11-97. 

C What is the altitude at apogee? 

C 

942 0 CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE (*, 420) 

READ (*, *,ERR=9420, IOSTAT=IERR) Apogee 

C 

C WHAT IS THE ALTITUDE AT PERIGEE? 

C 

9400 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (*, 400) 

READ (*, *,ERR=9400, IOSTAT=IERR) Perigee 

C allow the user to specify apogee and perigee in either order 

C instead of performing unintended calculation which sets eccentricity 

C to zero and using Perigee variable (actual apogee) to produce 

C a circular orbital altitude in ORBIT routine. 

IF (Perigee .GT. Apogee) THEN 
ApPerSwi t ch=Apogee 
Q Apogee=Perigee 
^ Perigee=ApPerSwitch 
^ WRITE (*, 430) 

3 ENDIF 

^ E= (Apogee -Perigee) / (Apogee+Perigee+2 . *Re) 

7^ IF (E.LT. .00001) E=0. 

"I ^ 

"~ C WHAT IS THE ORBITAL INCLINATION? 

\ C 

9405 CONTINUE 

^ CALL RETRY_INPUT(IERR) 

^ WRITE (*, 405) 

=^ READ (*, *,ERR=9405, IOSTAT=IERR) Orblncl 

H C READ in number of orbits, 11-26-97. 

C Have Removed "FAST" option, i.e. must enter Ascending Node information 
C 

C Retain these initializations in case want to hardwire ascending 

C node information at future time. 

AscNodeLong=0 . 
AscNodeDisp=0 . 
PerigDisp=0 . 

C Modified WRITE statement, 12-11-97. 



IF (E.NE.O.) THEN 

I dummy =3 
ELSE 

I dummy =2 
ENDIF 



WRITE (*, 409) Idummy 



WHAT IS THE INI 



LONGITUDE OF THE ASCENDING 



CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE{*,410) 

READ {*, *,ERR=9410, IOSTAT=IERR) AscNodeLong 

WHAT IS THE INITIAL DISPLACEMENT FROM THE ASCENDING NODE? 
CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE(*,415) 

READ (*, *,ERR=9415, IOSTAT=IERR) AscNodeDisp 

IF (E.NE.O.) THEN lOnly read in XI if eccentricity is nonzero 

What is the displacement of the perigee from the ascending node? 
CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE(*,425) 

READ (* , * , ERR=9425 , IOSTAT=IERR) PerigDisp 
ENDIF 

IF ( (AscNodeLong .NE. 0.0) .OR. (AscNodeDisp .NE. 0.0) .OR. 
(PerigDisp .NE. 0.0) ) WRITE (*, 426) 

Moved the entry of Norbits here, 12-11-97. 

CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (*, 408) 

READ (*,*,ERR=9408, IOSTAT=IERR) Norbits , Norbsteps 
READ (*, *,ERR=9408, IOSTAT=IERR) Norbits 
Norbsteps=200 ! hardwired at 200 for now, 11-26-97. 

IF (Norbits .LE. 0) Norbits=200 

IF (Norbsteps .LE. 0) Norbsteps=2 00 

End of moved section for entry of Norbits, 12-11-97. 
CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (*, 450) 

READ (*, *,ERR=9450, IOSTAT=IERR) ILbinMax 
IF (ILbinMax .LT. 0) ILbinMax=0 

IF (ILbinMax .GT. NLvals) THEN 

WRITE(*,456) 

ILbinMax - NLvals 
ENDIF 

IF (ILbinMax .GT. 0) THEN 
WRITE ( * , 4 51 ) ILbinMax 
CONTINUE 

CALL RETRY_INPUT(IERR) 

READ (*, *,ERR=9451, IOSTAT=IERR) (XLbounds (L) , L=l , IlbinMax) 



IF (ILbinMalBlQ. 1 .AND. XLBOUNDS(l) .EQ. WRITE (*, 458 ) 

ENDIF 

IF (XLbounds(l) .LT. 0.0) XLbounds (1) =0 . 0 



C Start DO loop at 1, so that ILbinMax-2 will be properly handled 

C This SUBROUTINE insists the L-values are in increasing order. 

C If this is not the case, all subsequent L-value bins will be 

C ignored. 



DO L=l, ILbinMax 

I F ( XLbounds ( L) . LT . XLbounds ( 1) ) THEN 

WRITE{*,452) XLbounds (L) ,XLinfinite 

XLbounds (L) =XLinf inite 
ENDIF 

IF (L .GE. 2) THEN 

IF (XLbounds (L) .LE. XLbounds (L-l) ) THEN 
WRITE (*, 452) XLbounds (L) ,XLinfinite 
XLbounds (L) =XLinf inite 
ENDIF 
ENDIF 
ENDDO 



ILbinsum=l 
^ DO L=l,ILbinMax 

5 IF ( (L .GE. 2) .AND. (XLbounds (L) .LT. XLinf inite) ) 

pi & ILbinsum=ILbinsum+l 

• ENDDO 

n1 IF (ILbinMax .NE. ILbinsum .AND. ILbinMax .NE. 0) THEN 

WRITE (* , 453) ILbinMax, ILbinsum 
^ ILbinMax=ILbinsum 
= ENDIF 

rU 9428 CONTINUE 

y CALL RETRY_INPUT(IERR) 

1==^ IF (ILbinMax .EQ. 0 .OR. (ILbinMax .EQ. 1 .AND. 

CI & XLBOUNDS (1) .EQ. 0.0) ) THEN 

■y WRITE (*, 427) 

READ ( * , 428 , ERR=:9428 , IOSTAT=IERR) TrappedFile 
CALL CHECK_OUTPUT_FILE (Trappedf ile , lACCEPT) 
IF (lACCEPT.NE.O) GOTO 9428 
ELSE 

WRITE (*, 455) ILbinMax 

READ (* , 428 , ERR=9428 , IOSTAT=IERR) TrappedFile 
CALL CHECK_OUTPUT_FILE (Trappedf ile , lACCEPT) 
IF (lACCEPT.NE.O) GOTO 942 8 
DO 1=1, LEN( TrappedFile) 

IF (TrappedFile (I: I) .EQ. '.') THEN 

TrappedFile=TrappedFile (1:1-1) 
ENDIF 
ENDDO 
ENDIF 



RETURN 



1000 FORMAT (IX, 'Orbit averaging using ESA AP8 Models.',/) 

1001 FORMAT (' This program will calculate the omnidirectional', 



& ' trappeJ^l^oton flux' , 

& /, ' to a' , 

& ' spacecraft orbiting inside the magnetosphere . The', 

& /,' calculated trapped flux is for demonstration purposes', 

Sc ' only, and is NOT part of the standard CREME96 software.', 

Sc//,' NOTE: Before running this or any other CREME96 programs', 
& ' please define three ' , 

& / , ' logicals : ' , / , 

Sc /,4x,' CREME96 as the directory where CREiyiE96 source', 

Sc ' & executables reside.', 

Sc /,4x,' CR96TABLES as the directory in which CREME96 data', 
Sc ' tables reside.', 

& /,4x,' USER as the directory in which output files', 

Sc ' should be written.', 

Sc //,' Now begin specification of the ESA AP8 calculation: ',/) 

390 FORMAT (IX, ' Enter 0 to directly calculate the trapped 

Sc 'proton fluxes, or ' , / , IX, ' Enter 1 to test the ', 

Sc ' pre-calculated trapped proton interf ace . ' , / , 3X, 

Sc ' [NOTE: The pre-calculated fluxes are presently ', 

Sc 'test case results which' ,/, IIX, 

Sc ' are intended only as a software test . ] ' ) 

391 FORMAT (IX, ' Enter 0 for Space Station (51.6 deg., 400 km)', 
p Sc ' orbit (ISSA) , ESA-AP8MAX, ' , 

^ Sc /,7X,'l for ISSA, ESA-AP8MIN, ' , 

^ & /,7X,'2 for 28.5 deg. (450 km), ESA-AP8MAX, ' , 

^ & /,7X,'3 for 28.5 deg. (450 km), ESA-AP8MIN. ' ) 

420 FORMAT (/, IX, 'Enter altitude at apogee (kilometers): ') 

400 FORMAT (/, IX, 'Enter altitude at perigee (kilometers): ') 

f^' 43 0 FORMAT (/, IX Input apogee < perigee, have been interchanged.') 

- 405 FORMAT (/, IX, 'Enter orbital inclination (degrees): ') 

ess: 

rU c Modified 12-11-97. 

LlJ 409 FORMAT (/, IX ,' The following ',11,' input parameters are ', 

Sc 'most relevant to situations in which' , 

L„g Sc /,lX,'the actual orbital path is known', 

%J Sc 'or in which mission critical operations', 

Sc /,lx,' are planned.', 

& //,3X,' [Recommended values are 0.0, unless you wish to examine', 

& /,3X,'a very specific orbital segment.]') 

410 FORMAT (/, IX, 'Enter initial longitude of ascending node', 

Sc IX, ' [Recommended = 0.0 (degrees) ] : ' ) 

415 FORMAT (/, IX, ' Enter initial displacement from ascending', 

1 ' node' , IX, ' [Recommended = 0.0 (degrees) ] : ' ) 

425 FORMAT (/, IX, 'Enter displacement of perigee from', 

1 ' ascending node', IX,' [Recommended = 0.0 (degrees)]:') 

426 FORMAT {/, IX, 'Note: for studies sensitive to a specific', 
Sc ' orbital segment, you should be' , 

Sc /, IX, 'aware that the trapped proton', 

Sc ' calculations are averaged over 7 days at present. This', 

Sc /, IX, 'parameter can be easily reset by modifying', 

Sc ' the TRAPPED_ORBINT siibroutine, but is ', 

& /,lx,'not provided as a general-use input parameter.') 




427 FORMAT (/, IX En^i^name of output trapped proton^^RLe : ' , 

& /, ' [Recommended: something . TRP] ' ) 

428 FORMAT (A80) 

450 FORMAT (/, IX, 'Enter the number of desired TRP L-value bins 
& ' (1 - 10) : ' , 

& /, 3X, ' [Recommended default = 0, i.e. 

& 'one trapped flux calculation for the entire orbit.]') 

451 FORMAT {/, IX, 

& 'Enter the lower limits of the ',12,' L-value bins: 

& /,3X,' [A typical scenario could be to request 4 bins as the', 

Sc ' as the previous entry. ' , 

Sc /,3X,'Then, entries of 0.0, 2.0, 4.0, and 6.0', 
Sc ' would subdivide the orbit into' , 

Sc /, 3x, ' sections with L < 2, L = 2-4, L = 4-6, and L > 6.]', 

Sc //,1X,'N0TE: The L-value is a magnetic coordinate roughly', 
Sc ' corresponding to the' , 

Sc /, IX, ' distance in Earth Radii to the', 
Sc ' magnetic field line at the magnetic equator.', 

& /,lx,'For example, a geosynchronous orbit is roughly L = 6.6,', 
& ' the geographic equator' , 

Sc /,lx,'is about L = 1, and the heart of the', 
Sc ' South Atlantic Anomaly (SAA) is roughly at' , 

Q & /,lx, 'L = 1.2 - 2. ' , 

-^n Sc ' Calculated L- values slightly less than 1 do occur; using' , 

Q & /,lX,'a lower limit of L = 0 will account for these.') 

f[| 452 FORMAT ( IX ,' The L-values MUST be entered in increasing order', 

Q & /,lX,'the L-value of ',F10.2,' has been reset to ',F10.2) 

rr 453 FORMAT ( IX ,' The number of L-values bins has been reset', 

Sc /,1X,' from ',12,' to ',12) 

^ 454 FORMAT (/, IX, 

ij! & 'Enter 0 (default) for AP8MIN (1964)', IX, 

Sc 'or 1 for AP8MAX (1970).') 



455 FORMAT (/, IX, ' Enter root name of output TRP files:', 

Sc /, IX, '[NOTE: There will be ',12,' output files, and', 
Sc ' the files for the different L-value' 

Sc /,lx,' bins will', 

Sc ' be called something . TR# (# = 1 , 2 , . . . , 9 , X) ] ' ) 

456 FORMAT (IX, 'Only 10 L-values are allowed.') 

458 FORMAT (IX, ' Calculation reset to whole orbit option, since', 
& IX, 'choosing 1 L bin', 

& /,1X,' with a minimum L-value equal to 0 is equivalent to', 

Sc IX, 'the entire orbit.') 

408 FORMAT (/, IX, 

Sc 'Enter Number of orbits to integrate (default = 200)') 

CF? 408 FORMAT (/, IX, 

CF? Sc 'Enter Number of orbits to integrate (default = 200)',/, 

CF? Sc 3X,'and Number of steps per orbit') 



END ! TrappedDriverlnput routine 



SUBROUTINE OutputTrappedFliix (Evals , NE, TrappedFlux, 

# Dif f TrappedFlux, TrappedFile , Orblncl , 

# Apogee, Perigee, AscNodeLong,AscNodeDisp, Per igDisp, 

# Year, XLbounds, ILbins, PROGRAM_CODE , imod, RelDwellTime, 

# DistBelt, PreCalcFlux, IPreCalc, ELOWER, EUPPER, MPTS , 

# Eout , Fliixout , Ndays , Norbits , Norbsteps , 

# OrbPer iod , OrbPrecTime ) 

C 

C TEST Routine for writing the orbit -averaged APS trapped proton f Ixixes . 

C 

IMPLICIT NONE 

INTEGER* 4 I , L, OUTUNIT, lOLEN, NE 
DATA OUTUNIT/2/ 
INTEGER* 4 NHEADER 

CHARACTER* 80 TrappedFile , TEMPFILE 
CHARACTER* 9 CREATION_DATE 
CHARACTER* 8 CREATION_TIME 

INTEGER iemax,NLvals, ILbins 
PARAMETER ( i emax=: 3 0 , NL va 1 s = 1 0 ) 

^ REAL*4 YEAR 

n INTEGER*4 VERSION_NUMBER, PROGRAM_CODE, imod 

□ REAL*4 ELOWER, EUPPER 

fU CHARACTER* 12 TARGET 

DATA TARGET/ ' UNSHIELDED ' / 

: : 

yj 

REAL TrappedFlux (iemax, NLvals) , Evals (iemax) , XLbounds (NLvals) 
REAL RelDwellTime (NLvals) 



5 

ru 



REAL DiffTrappedFlux{ iemax, NLvals) 



INTEGER MARR,K,MPTS 
PARAMETER (MARR=5000) 
REAL Eout (MARR) , Fluxout (MARR, NLvals ) 



REAL Orblncl , Apogee, Perigee, AscNodeLong, As cNodeDisp, PerigDisp 
REAL XLinfinite 

PARAMETER (XLinf inite=l . OE+06 ) 
REAL Fconv 



CC For converting flux to /sr-m**2-s from /cm**2-day, assuming isotropic 

CC flux. TrappedFlux is in /sr-m**2-s, Dif f TrappedFlux in /sr-m**2-s-MeV 

CC Fconv = 1. OE+4/ {4*PI*86400) . 

CC PARAMETER (Fconv=9 . 210356E- 02 ) 

PARAMETER { Fconv=7 . 957747155E+02 ) ! 86400 * other Fconv (commented out) 

CHARACTER* 4 FEXT(IO) 



DATA FEXT/ ' . TRl ' , ' . TR2 ' , ' . TR3 ' , ' . TR4 ' , ' . TR5 ' , ' . TR6 ' , ' . TR7 ' , 



& ' .TR8' , ^^^9' , ' .TRX' / 

INTEGER IpreCalc 

LOGICTVL DistBelt, PreCalcFlux 

INTEGER CREME96_OPEN, Stat 

INTEGER Ndays,Norbits,Norbsteps 'passed as arguments, 11-26-97. 

C Add orbital period, 12-1-97. OrbPrecTime is for future use, 11-26-97. 

REAL Orbper iod , Orbper iodHrs , OrbPrecTime 

C Note that IDistBeltOutput is presently neither used nor output, 11-26-97. 

INTEGER IPreCalcOutput, IDistBeltOutput 111-26-97. 

INTEGER IPreCalcTmp . 112-1-97, for internal consistency & error checking. 

INTEGER INPUNIT 111-26-97 
DATA INPUNIT/ 3/ 

REAL PCf luxpts (iemax) , Dif f PCf luxpts (iemax) 111-26-97 
INTEGER VERSION_TMP,CODE_TMP 111-26-97 

REAL PCFluxes (MARR) 111-26-97 

^ INTEGER IZLOW,IZHIGH 111-26-97 

Q CHARACTER*6 APtitle 

; ^ 

Q CHARACTER* 80 PreCalcFile , TITLELINE 

y C 

M 

_ CALL GET_CREME96_VERSION(VERSION_NUMBER) 

IPreCalcputput=0 111-26-97 
f;; OrbperiodHrs=Orbperiod/3600 . 0 

r: IF (PreCalcFlux) THEN 

■"^ DistBelt= . FALSE . ! Local variable for header output file. 

~: IPreCalcOutput=l 1 Local variable for header output file. 

cf? IpreCalc = 1 & 3 are AP8MIN calculations, 11-26-97. 

cf? IF ( {IpreCalc .EQ. 1) .OR. (IpreCalc .EQ. 3) ) 

cf? & DistBelt=.TRUE. 

ENDIF 

IDistBeltOutput=0 
cf? IF (DistBelt) IDistBeltOutput=l 

IF {.NOT. PreCalcFlux) THEN 111-27-97. 
C Open output file and write header 

C ILbins = 0 & ILbins = 1 from input routine are treated 

C as ILbins = 1 for output, since they are stored in the 
C same location in the array. 

IF (ILbins .EQ. 1 .AND. XLBOUNDS(l) . EQ . 0.0) THEN 
C OPEN (UNIT=OXJTUNIT,STATUS=' NEW ,FILE='USER: ' //TrappedFile) 

Stat = creme96_open {TrappedFile, 'user' ,outunit, 'new' ) 
CALL DATE (CREATION DATE) 



CALL TIME (GREAT 
C 

C Now prepare header for output file: 
NHEADER=23 

WRITE (OUTUNIT, 990) NHEADER, TrappedFile ( 1 : 70) , 
& VERS ION_NUMBER , PROGRAM_CODE 

WRITE (OUTUNIT, 992) VERSION_NUMBER, CREATION_DATE , CREATION_TIME 

WRITE (OUTUNIT , 404 ) Orblncl , Apogee , Perigee , AscNodeLong , 
# AscNodeDisp , PerigDisp 



c RelDwellTime should be 1.0 in this case. 

IF (imod .EQ. 1) 

# WRITE (OUTUNIT, 405) 'AP8MIN' , imod- 1 , IPreCalcOutput , 

# RelDwellTime (Ilbins) ,XLbounds (ILbins) , 

# XLbounds (Ilbins+1) 

IF (imod .EQ. 2) 

# WRITE (OUTUNIT, 405) 'AP8MAX' , imod- 1 , IPreCalcOutput , 

# RelDwellTime (Ilbins) , XLbounds (ILbins) , 
O # XLbounds (Ilbins+1) 

O WRITE (OUTUNIT, 411) Norbits , Norbsteps 

Q cf? WRITE (OUTUNIT, 411) Norbits , Norbsteps , OrbPrecTime 



WRITE (OUTUNIT, 412) OrbPeriodHrs 

WRITE (OUTUNIT, 9195) 
WRITE (OUTUNIT, 9196) 

DO 1=1, NE, 2 

WRITE (OUTUNIT, 9200) (Evals (K) , TrappedFlux (K, ILbins) *Fconv, 

# Dif f TrappedFlux (K, ILbins) *Fconv, K=I , I+l) 
END DO 

WRITE (OUTUNIT ,9100) ELOWER , EUPPER , MPTS ,1,1, TARGET , YEAR , NE , 

# VERS ION_NUMBER , PROGRAM_CODE 
WRITE (OUTUNIT, 100) 

C Write trapped proton fluxes to file in standard CREME96 format, 

WRITE (OUTUNIT, 200) (Fconv*FluxOut (K, ILbins) ,K=l,Mpts) 
WRITE (OUTUNIT, 100) 

CLOSE (OUTUNIT) 

ELSE 

DO 1=1,66 

IF (TrappedFile (I : I) .NE. ' ' .AND. 
& TrappedFILE(I+l:I+l) .EQ. ' ') IOLEN=I 

ENDDO 



c 



DO L=l, ILbins 

TEMPFILE=TrappedFILE (1 : lOLEN) //FEXT (L) 
OPEN (UNIT=OUTUNIT,STATUS=' NEW' ,FILE='USER: ' //TEMPFILE) 



Stat = creme^^op en (TEMP FILE, 'user' , out unit , Tfew' ) 
CALL DATE (CREATION_DATE) 
CALL TIME (CREATION_TIME) 

C Now prepare header for output file: 

NHEADER=23 

WRITE (OUTUNIT, 990) NHEADER, TEMPFILE (1 : 70) , 
& VERS ION_NUMBER , PROGRAM_CODE 

WRITE (OUTUNIT, 992) VERSION_NUMBER, CREATION_DATE , 
& CREATION_TIME 

WRITE (OUTUNIT, 404) Orblncl , Apogee , Perigee , AscNodeLong, 

# AscNodeDisp, PerigDisp 

IF (L .LT. NLvals) THEN 
IF (imod .EQ. 1) 

# WRITE (OUTUNIT, 405) 'AP8MIN' , imod- 1 , IPreCalcOutput ; 

# RelDwellTime (L) , XLbounds (L) , XLbounds (L+l) 

IF (imod .EQ. 2) 

# WRITE (OUTUNIT, 405) 'AP8MAX' , imod- 1 , IPreCalcOutput , 
_ # RelDwellTime (L) , XLbounds (L) , XLbounds (L+l) 

D ELSE 

IF (imod .EQ. 1) 

□ # WRITE (OUTUNIT, 405) 'APSMI'N' , imod- 1 , IPreCalcOutput , 
Q # RelDwellTime (L) , XLbounds (L) , XLinf inite 

fij IF (imod .EQ. 2) 

□ # WRITE (OUTUNIT, 405) ' AP8MAX imod- 1 , IPreCalcOutput , 
Ijj # RelDwellTime (L) , XLbounds (L) , XLinf inite 

12 ENDIF 

WRITE (OUTUNIT, 411) Norbits , Norbsteps 
cf? WRITE (OUTUNIT, 411) Norbits , Norbsteps , OrbPrecTime 



WRITE (OUTUNIT, 412) OrbPeriodHrs 

WRITE (OUTUNIT, 9195) 
WRITE (OUTUNIT, 9196) 

DO 1=1, NE, 2 

WRITE (OUTUNIT, 9200) (Evals (K) , TrappedFlux (K, L) *Fconv, 
Dif f TrappedFlux (K, L) *Fconv, K=I , I+l) 
END DO 

WRITE (OUTUNIT , 9100) ELOWER , EUPPER , MPTS ,1,1, TARGET , YEAR , NE , 
VERSION_NUMBER, PROGRAM_CODE 
WRITE (OUTUNIT, 100) 

Write trapped proton fluxes to file in standard CREME96 format. 

WRITE (OUTUNIT, 2 00) (Fconv*FluxOut (K, L) ,K=l,Mpts) 
WRITE (OUTUNIT, 100) 

CLOSE (OUTUNIT) 

ENDDO ! number of'L-bins. 



ENDIF ! choosing between whole orbit and L-bin options. 




ELSE ! handle pre-calculated trapped fluxes, 11-26-97. 

Presently, there are no L-bins for pre-calculated trapped fluxes. 

IF {IPreCalc .EQ. 0) PreCalcFile=' IPRECO .TRP' 

IF (IPreCalc .EQ. 1) PreCalcFile=' IPRECl .TRP' 

IF (IPreCalc .EQ. 2) PreCalcFile= ' IPREC2 .TRP' 

IF (IPreCalc .EQ. 3) PreCalcFile= ' IPREC3 . TRP' 

Stat = creme96_open (PreCalcFile, ' cr96 tables ', inpunit, ' old' ) 
Stat = creme96_open(TrappedFile, 'user' ,outunit, 'new' ) 

CALL DATE (CREATION_DATE) 
CALL TIME (CREATION_TIME) 

NHEADER=23 

WRITE (OUTUNIT, 990) NHEADER, TrappedFile ( 1 : 70 ) , 
& VERS ION_NUMBER , PROGRAM_CODE 

WRITE (OUTUNIT, 992 ) VERS ION_NUMBER , CREATION_DATE , CREATION_TIME 

READ (INPUNIT, 9194) TITLELINE I dummy title lines from creation of 
READ (INPUNIT, 9194) TITLELINE ! pre- calculated trapped fluxes. 

READ (INPUNIT, 1404) Orblncl , Apogee , Perigee , AscNodeLong, 

# AscNodeDisp, PerigDisp 

WRITE (OUTUNIT, 4 04) Orb I nc 1 , Apogee , Perigee , AscNodeLong, 

# AscNodeDisp, PerigDisp 

READ (INPUNIT, 14 05) APtitle , imod, IPreCalcTmp 

READ (INPUNIT, 14 06) RelDwellTime(Ilbins) , XLbounds (ILbins) , 

# XLbounds (I lbins+1) 

WRITE (OUTUNIT, 405) APtitle , imod, IPreCalcOutput , 

# RelDwellTime (Ilbins) , XLbounds (ILbins) , 

# XLbounds (Ilbins+1) 

READ (INPUNIT, 1411) Norbits , Norbsteps 
WRITE (OUTUNIT, 411) Norbits , Norbsteps 

READ (INPUNIT, 1412) OrbPeriodHrs 
WRITE (OUTUNIT, 412) OrbPeriodHrs 

READ (INPUNIT, 9194 ) TITLELINE 
WRITE (OUTUNIT, 9194 ) TITLELINE 
READ (INPUNIT, 9194) TITLELINE 
WRITE (OUTUNIT, 9194 ) TITLELINE 

NE = 29 'presently hardwired for pre-calculated fluxes. 
DO 1=1, NE, 2 



READ (INPUNIT, 92 01) Evals(I) , PCf luxpts ( I ) , 

# Diff PCf luxpts (I) ,Evals(I+l) , PCf luxpts (I+l) , 

# Diff PCf luxpts (I+l) 

WRITE (OUTUNIT, 9200) (Evals (K) , PCf luxpts (K) , 

# Diff PCf luxpts (K) ,K=I, I+l) 



END DO 




READdNPUNIT, 9100) ELOWER, EUPPER, MPTS , IZLOW, IZHIGH, TARGET, 

# YEAR , NE , VERS ION_TMP , CODE_TMP 
READdNPUNIT, 100) 

WRITE (OUTUNIT, 9100) ELOWER, EUP PER, MPTS , IZLOW, I ZHIGH , TARGET, 

# YEAR , NE , VERS ION_NUiyiBER , PROGRAM_CODE 
WRITE (OUTUNIT, 100) 

C Write trapped proton fluxes to file in standard CREME96 format. 

READdNPUNIT, 200) (PCFluxes (K) ,K=l,Mpts) 
WRITE (OUTUNIT, 200) (PCFluxes (K) ,K=l,Mpts) 

READdNPUNIT, 100) 
WRITE (OUTUNIT, 100) 

CLOSE (INPUNIT) 
CLOSE (OUTUNIT) 

ENDIF I for regular vs. pre-calculated trapped fluxes, 11-26-97. 
Q C FORMAT statements 

0 100 FORMATdX, 2 (IPEIO .4, 2X) , 3 (15, 2X) , A12, 

n & 2X, 0PF8 .3, Ix, 12, Ix, II, Ix, 14, Ix, II) 

□ 200 FORMAT( (1X,6(1PE10.4,2X) ) ) 

404 FORMAT (Ix, '%Incl = ' , F7 . 3 , ' deg Apo = ',E10.4, 

1 # ' Peri = ',E10.4,' km' , Ix, 3 {F6 . 2 , Ix) ) 

^ 405 FORMAT (Ix, '%' ,A6, IX, 'IMOD = ' , 12 , IX , ' IPRECALC =',I2,/,1X, 
:^ # '%Relative dwell time = ',E10.4,1X, 

# 'L Bin: ' , 2 (ElO . 4 , IX) ) 

C Number of steps per orbits is presently fixed at 200, and 

C the orbital procession period is not presently calculated, 11-26-97. 

411 FORMATdX, '%No. orbits = ' , 18 , 2X, ' No . steps/orbit = ',16) 

cf? 411 FORMATdX, ' %No. orbits = ' , 18 , 2X, ' No . steps/orbit = ',16, 
cf? # 'Precession Period = ',E10.4) 

412 FORMATdX, '%Orbital period = ' , F8 . 2 , IX, ' hours ' ) 
990 FORMAT (13, lx,A70, 14, Ix, II) 

992 FORMATdX, ' %Crea ted by TRAPPED_DRIVER Version ',14, 
& ' on ' , A9, ' at ' ,A8) 

9100 FORMATdX, 2 (IPElO. 4, 2X) ,3 {I5,2X) , A12 , 2X , 0PF8 . 3 , IX, 14 , IX , 14 , IX , II ) 

9195 FORMATdX, ' %Calculated energies, integral fluxes, and ', 
& 'differential fluxes') 

9196 FORMATdX, '%' ,3X, 'MeV ,7X, '/m**2-sr-s' ,2X, ' /m**2 - sr- s-MeV ,3X, 
& 'MeV ,7X, '/m**2-sr-s' ,2X, ' /m**2 -sr-s-MeV ) 

9200 FORMAT ( (IX, ,1X,3 (1PE10.4,2X) , 3X, 3 dPE10.4,2X) ) ) 
9210 FORMAT ( (IX, 3 (1PE10.4,2X) ) ) 



C FORMAT lines for^Kding pre-calculated files, 11^^-97 and 12-1-97. 



1404 FORMAT (Ix, 8X, F7 . 3 , 12X, ElO . 4 , 8X, ElO . 4 , 3X, Ix, 3 (F6 . 2 , Ix) ) 

1405 FORMAT (Ix, IX, A6 , IX , 6X, 12 , IX, lOX, 12) 

1406 FORMAT(1X,23X,E10 .4, IX, 7X, 2 (E10.4, IX) ) 

1411 FORMATdx, 13X, 18, 2X, 18X, 16) 

1412 FORMAT (Ix, 18X, F8 . 2 , IX, 5X) 

9194 FORMATdx, A7 9) 

9201 FORMAT( (IX, IX, IX, 3 (IPEIO . 4 , 2X) , 3X, 3 (IPEIO . 4 , 2X) ) ) 

RETURN 
END 

C 

SUBROUTINE Trapped_ORBINT (Orblncl , Apogee , Perigee , AscNodeLong , 

# AscNodeDisp, PerigDisp, Evals , NE, sumexp,d, 

# Year , XLbounds , ILbins, imod, RelDwellTime , 

# DistBelt , PreCalcFlux, IPreCalc,Ndays, 

# Norbits , Norbsteps , Period, OrbPrecTime) 

p IMPLICIT NONE 

Q INTEGER J, Jmax , L , Ndays , NorbSteps , IPreCalc , NLvals , Norbits 

Q INTEGER NE , imod 

Q C Establish Norbits & Norbsteps in TrappedDriver Input , 11-26-97. 

Q PARAMETER (NLvals=10) 

LOGICAL DistBelt, PreCalcFlux 

C Initial Orbital parameters are set in Subroutine TrappedDriver Input . 

s hi 

REAL Orblncl, Apogee, Perigee, AscNodeLong, AscNodeDisp, PerigDisp 
^ REAL Time, Period, Step . 

"'-^ C Parameters along each orbital step 

REAL Zlat, Zlon,Alt 

INTEGER ILbins, ILbin, ICODE,NperLbin (NLvals) 
REAL Year, XLval,BB0, XLbounds (NLvals) ,XLinfinite 
PARAMETER (XLinf inite=l . OE+06 ) 

INTEGER IE,iemax 

parameter (iemax =30) ! MAX NO. OF ENERGIES ALLOWED 
real Evals (iemax) 

REAL RelDwellTime (NLvals) 

REAL flux (iemax), expose (iemax) 

REAL sumexp (iemax, NLvals ) , fluxi (iemax, NLvals) 

REAL difedl (iemax, NLvals) , d (iemax, NLvals) 

real*4 b, delt !B is mag. field, delt=step (time interval) 
real* 4 yearp 



real* 8 gmagmo 



common /gmagmo/ ^B^mol for esa traraln 
SAVE 

real OrbPrecTime 'for future use, 12-1-97. 



C Initializations 

DO L=l,NLvals 
NperLbin (L) =0 
do ie=l,ne ! 
sumexp (ie, L) 
f luxi (ie, L) 
enddo 
ENDDO 

do ie=l,ne ! initailize arrays 

expose (ie) = 0.0 
enddo 

IF (PreCalcFlux) THEN 



initailize arrays 
= 0. 
= 0. 



C The output routine OutputTrappedFlux handles getting the 

C pre-calculated trapped fluxes. We simply return with 

C the proper flag. 

RETURN ! could just use subsequent RETURN, since this IF statement 
! skips all lines before the subsequent RETURN 

ELSE ! calculate trapped flux if not using pre-calculated ones 

C Initialize Orbit routine 

CALL Orbit (1, Period, ZLon, ZLat , Alt , Apogee , Perigee, Orblncl , 
# AscNodeLong, AscNodeDisp, PerigDisp) 

C Compute the total number of steps in "Ndays" days if we make 

C "Norbsteps" steps per orbit. Use 2 days and 200 steps per orbit 

C presently. 

C 

NDAYS=INT(NorbitS*PERIOD/86400. +1.0) 

JMAX= INT (Ndays* NorbSteps*86400 . /PERIOD +1.5) 

C 

C Compute the step size in seconds. 

C 

STEP=PERIOD/FLOAT (NorbSteps) 
delt=STEP 



DO J=1,JMAX 
time=FLOAT{ j -1) *step 



CALL Orbit (2 , Time, ZLon, ZLat , Alt , Apogee, Perigee, Orblncl , 



iNodeLong , AscNodeDisp , PerigDis]^ 



call blccoords (Zlat , Zlon, Alt , Year, imod, BBO , XLval , yearp, B) 

IF ( XLbounds{2) .LT. XLinfinite .OR. 

(• XLbounds (2) .GE. XLinfinite .AND. 
XLbounds ( 1 ) . GT . 0.0 ) ) THEN 

IF (XLval .GT. 99999.0) XLval=99999 . 0 

CALL GetLbin (XLval , XLbounds , ILbins , ILbin) 

IF (ILbin .GE. 1 .AND. ILbin .LE. NLvals) 
NperLbin ( ILbin) =:NperLbin ( ILbin) +1 

ELSE 

If no L-bins are specified or 1 L-bin is specified 
and the lower bound is L = 0, use only the first 
element of the array. In this case, the following 
sum should equal JMAX once the stepping through the 
orbit is completed. 

ILbin=l 

NperLbin (Ilbin) =NperLbin (Ilbin) +1 
ENDIF 

Now pass B, L (XLval) , imod, e , ne to subroutine trapped_j>rot 
return integral flux and yearp 

call trapped_protons (B, XLval, yearp, imod, evals (1) ,flux(l) ,ne) 

IF (ILbin .GE. 1 .AND. ILbin .LE. NLvals) THEN 
do ie = 1, ne 

expose (ie) = flux(ie) * delt 

sumexp (ie, ilbin) = sumexp ( ie , ilbin) + expose (ie) 
enddo 

ENDIF I for within allowed Lbins 

ENDDO Ifor number of orbital steps (up to JMAX) 

DO L=l, ILbins 
do ie = 1, ne 

sumexp (ie, L) 
enddo 

RelDwellTime (L) 



do ie = l,ne-l 
difedl (ie,L) 
enddo 

difedl {ne,L) = sumexp (ne,L) 
ENDDO ! stepping through L-bins 

call differ (ne, evals, sumexp, difedl, d, Ilbins) 



= sumexp (ie,L) / (FLOAT (NperLbin (L) ) *delt) 



FLOAT (NperLbin (L) ) / 
FLOAT (Jmax) 



= sumexp (ie,L) - sumexp (ie+1, L) 



do L = l,ILbir 

do ie = 1, ne 

IF (d(ie,L) .LE. l.OE-20) d(ie,L) = 0.0 

enddo 
enddo 



ENDIF ! f or using either pre-calculated or directly-calculated Fluxes 

RETURN 
END 



C The following GetLbin routine is identical to the routine in GEOMAG96 . 

C In order to avoid linking with all of GEOMAG96, it is included here 

C for now. Before releasing, this should be in a standalone module 

C that can be called from either the GTRANS DRIVER or the TRAPPED DRIVER. 



SUBROUTINE GetLbin (XLval , XLbounds , ILbins , ILbin) 

IMPLICIT NONE 
a INTEGER ILbins, ILbin, NLvals,L 

.a PARAMETER (NLvals=10) 

□ REAL XLval, XLbounds (NLvals) 

Q LOGICAL FindLbin 

3 y 

'f=r^ C No attempt is made to eliminate "unphysical" or "approximate" 

C L-values using the ICODE returned from GET_BLCOORDS , since any 

^ C analyses using L-values are likely to handle these locations 

C "as is", i.e. with the calculated L- value. 

'r^__ c 



FindLbin= . TRUE . 

ILbin=0 

DO L=l, ILbins 
IF (FindLbin) THEN 

IF (L .LT. NLvals) THEN 

IF { (XLval .GE. XLbounds{L)) .AND. 
(XLval . LT . XLbounds (L+1) ) ) THEN 
ILbin=L 

FindLbin= . FALSE . 
ENDIF 

ELSE ! special handling of L=NLvals case 

I F ( XLval . GE . XLbounds ( L ) } THEN 
ILbin=L 

FindLbin= . FALSE . 
ENDIF 

ENDIF ! checking of each L-bin 



ENDIF 
ENDDO 



! for FINDLbin logical 



RETURN 
END 



This should be a dead subroutine now, 11-26-97. 

SUBROUTINE GetPreCalcFlux (IPreCalc , Evals , TrappedFlux, 
& Diff TrappedFlux, DistBelt, imod) 

IMPLICIT NONE 

INTEGER IPreCalc, NLvals,NE, imod, I,L, iemax 
PARAMETER ( i emax= 3 0 , NLval s = 1 0 ) 
LOGICAL DistBelt 

Initial Orbital parameters are set in Subroutine TrappedDriverlnput . 
real Evals (iemax) 

REAL Trappedf lux (iemax, NLval s) , DiffTrappedf lux (iemax, NLval s) 
REAL RelDwellTime (NLvals) 



RelDwellTime (1) =1 . 0 

DO 1=1, iemax 
DO L=2, NLvals 

Trappedf lux (i, L) =0 . 0 
DiffTrappedf lux (i, L) =0 . 0 
ENDDO 
ENDDO 

DO L=2, NLvals 

RelDwellTime (L) =0 . 0 
ENDDO 

Need to set Evals, Trappedf lux (*, 1) , & DiffTrappedf lux (*, 1) 
when actually implement routine. Also change STOP TO RETURN 

WRITE (*, ' (IX, ' ' Pre-calculated trapped fluxes are presently' ' , 
# IX, ' 'not available. ' ' , /, IX, ' 'Aborting Trapped_Driver ' ' ) ' ) 

STOP ! RETURN 
RETURN 

END 



SUBROUTINE Trapped_Spectra (Evals , NE, ELOWER , EUPPER , M , ILbins , 
TrappedFlux, Dif f TrappedFlux, Eout, Fluxout) 

IMPLICIT NONE 



INTEGER NLvals, IEmax,NE, ILbins 
PARAMETER (NLval s =1 0 , IEmax=3 0) 



REAL Evals ( lEma!^, Dif f TrappedFlux ( lEmax, NLvals 
REAL TrappedFlux (lEmax, NLvals) 
REAL DiffFluxSPin(IEmax) 

REAL ELOWER,EUPPER,DE 

INTEGER MARR,M, I, J,K,NEsp,Kl 
PARAMETER (MARR=5000) 

REAL Eout (MARR) , Fliixout (MARR, NLvals) , Dif f FluxSPout (MARR) 

REAL D2FLUX(500) , DUMMYFLUX { 5 0 0 ) , DERI VLOW, DERI VHIGH 

LOGICAL NATURAL (2) 

INTEGER NElogmin , NElogmax , NElog 

REAL D2LOGFLUX(500) ,DUMiyiYLOGFLUX(500) 
REAL DERIVLOGLOW,DERIVLOGHIGH 

REAL EvalsLog (lEmax) , Elogout (MARR) , Dif f FluxLogout (MARR) 
REAL Dif f Fl\ixlog (lEmax) 

INTEGER Jmax 111-24-97 



Compute energies on logaritmically- spaced grid 
M=1002 

DE= (EUPPER/ELOWER) ** ( 1 . / (M- 1 . ) ) 

EOUT(l) =ELOWER 

ELOGOUT ( 1 ) =LOG (EOUT ( 1 ) ) 

DO J=2,M-1 

EOUT (J) =EOUT (J-1) *DE 
ELOGOUT (J) =LOG (EOUT (J) ) 
END DO 

EOUT (M) =EUPPER 

ELOGOUT (M) =LOG (EOUT (M) ) 

Initialize FluxOut 
DO I = 1, ILbins 

DO J=1,M 

FluxOut (J, I) =0.0 

END DO 
END DO 

EOUT (M) =EUPPER 

NATURAL (1) = . TRUE . 
NATURAL (2 ) = . TRUE . 

DO I = 1, ILbins !set up and CALL SPLINE for each L- value bin. 

NEsp=0 
NElogmin=0 
NElogmax=0 
Jmax=0 



DO J=1,IEMAX ! establish array for passing into SPLINE & SPLINT 



Dif f FliixSPinTVi=Dif f TrappedFlux (J, I) 

Eliminate points at which differential flux is not well 





behaved (monotonically decreasing), 11-24-97. 
IF {DiffFluxSPin{J) .GT. 0.0) THEN 

Eliminate points at which differential flux=0, 11-24-97. 

Jmax=J 
NEsp=NEsp+l 

IF (NElogmin .EQ. 0) NElogmin=J 

Dif f FluxLog (NEsp-Nelogmin+1) =LOG (Dif f FliixSPin (J) ) 
EvalsLog (NEsp-Nelogmin+1) ==LOG (Evals (J) ) !J to NEsp, 11-24-97 
ENDIF 
ENDDO 

NElogmax=NEsp 

NElog=NElogmax-NElogmin+l 

IF (Nesp .GT. 1) THEN 

CALL SPLINE{EvalsLog,DiffFluxLog,NElog,500, NATURAL 
> ,0.0,0.0, D2L0GFLUX , DUMMYLOGFLUX ) 

DO K=1,M ! f or calculating at the standard CREME96 energies 



> 



CALL SPLINT (Eval Slog, Dif f FluxLog, D2L0GFLUX, 

NElog,Elogout (K) , Dif f FluxLogout (K) ) 



IF (Eout(K) .LT. 1.0 .OR. 



Eout(K) .GT. Evals(Jmax)) THEN !NEsp to J, 11-24-97. 



Fluxout (K, I) =0 . 0 
ELSE 



Fluxout (K, I) =EXP (Dif f Fluxlogout (K) ) 
ENDIF 



ENDDO 



!K=1,M 



ENDIF 



ENDDO 



11=1, ILbins 



RETURN 
END 



SUBROUTINE ULET9 




Slower , supper , target , 

ELOWER , EUPPER , M , I ZLO , I ZUP , 

FLUX,LDUM, 

SPECT) 



Sc 



c 

C Creates an LET spectrum in standard format from an energy 

C spectrum in standard format . 

C 

C Inputs : 

C SLOWER, SUPPER = min, max LET values (in MeV-cm2/g not /mgl ) 

C TARGET = target material (CHARACTER*?, generally SILICON) 

C FLUX Contains the energy spectra of up to NELM elements specified at 

C up to MARR energies 

C ELOWER , EUPPER = min, max energy of particle spectra 

CM = number of bins in energy spectra 

C I ZLO, I ZUP = min, max atomic numbers in LET spectrum. 

C LDUM = number of bins in integral LET spectrum (</= LARR=1002) 

C Outputs : 

C SPECT = output LET spectrum 



C* ********************************************************** 
IMPLICIT NONE 

INTEGER*4 MARR, NELM, LARR, M, IZLO, IZUP , LDUM, L, J, K, I , IK 

PARAMETER (MARR=5000 , NELM=92 , LARR=1002 ) 

REAL*4 FLUX (NELM, MARR) ,E (MARR) , SP (NELM, MARR) 

REAL*4 SPECT (LARR) , SL (LARR) 

REAL*4 AMASS 

COMMON/MASS /AMASS (109) 

CHARACTER TARGET* 12 

REAL*4 SLOWER, SUPPER, ELOWER, EUPPER, DE, DS , RSP, FUN, XK, ADD 

C Construct list of energies 

DE= (EUPPER/ELOWER) **(!./ (M-1. ) ) 
E (1) =ELOWER 
DO J=2,M-1 

E(J) =E (J-1) *DE 
END DO 
E (M) =EUPPER 

L=LDUM 

IF (L.GT.LARR) L=LARR 

C Construct list of stopping powers 

DS= (SUPPER/SLOWER) ** (1 . / (L- 1 . ) ) 
SL(1) =SLOWER 
DO J=2,L 

SL{J) =SL(J-1) *DS 
END DO 

SL(L) =SUPPER 

C Now get table of stopping powers 

CALL UNLOAD_S TABLE ( ELOWER , EUPPER , M , I ZLO , I ZUP , TARGET , S P ) 

C Initialize spectrum 



C 



DO J=1,L 

SPECT (J) =0. 
END DO 



For each energy find stopping power index and increment 
all lower stopping powers 

RSP=1. /SLOWER 
FUN=1 . /LOG (SUPPER/SLOWER) 
DO J=IZLO,IZUP 
DO K=1,M 

XK=1.+(L-1. ) *LOG (SP(J,K) *RSP) *FUN 

IK=INT{XK) 

IF (K.EQ.l) THEN 

ADD=FLUX(J,K) * {E(K+1) -E (K) ) *0.5 
ELSE IF (K.EQ.M) THEN 

ADD=FLUX ( J, K) * (E (K) -E (K-1) ) *0 . 5 
ELSE 

ADD=:FLUX(J,K) * (E (K+1) -E (K-1) ) *0.5 
ENDIF 
DO 1=1, IK 

IF (I.LT.IK) THEN 

SPECT ( I ) =SPECT ( I ) +ADD 
ELSE IF (I.EQ.IK) THEN 

SPECT ( I ) =SPECT { I ) +ADD* (XK- IK) 
ENDIF 
END DO 
END DO 
END DO 

RETURN 
END 



SUBROUTINE UNLO. 




:EME96 FLUXdNFILE, 



* 



SLOWER, EUPPER,M, IZLO, IZUP, 
FLUX) 



IMPLICIT NONE 
INTEGER*4 MARR,NELM 
PARAMETER (MARR=5000 , NELM=92 ) 
REAL*4 FLUX(NELM,MARR) 
REAL*4 SLOWER, EUPPER 

INTEGER* 4 M , I ZLO , I ZUP , J , K , I VER , KVER , KPROG , NHEADER 
INTEGER*4 STAT , CREME96_OPEN 
CHARACTER*80 INFILE,ILINE 

CALL CHECK_CREME96_VERSION ( INFILE , IVER) 

OPEN(UNIT=25, STATUS =' OLD' , READONLY, FILE USER : ' //INFILE) 
Stat = creme96_open (inf ile, ' user ' , 25 , ' old' ) 

IF ( IVER. GE. 102) THEN 
READ (25,*) NHEADER 
DO J=l, NHEADER 

READ (25, 110) ILINE 
FORMAT (A80) 
ENDDO 
ENDIF 

READ (25,*) ELOWER , EUPPER , M , I ZLO , I ZUP 

READ (25, *) 

DO 100, J=IZLO, IZUP 

READ (25, *) (FLUX (J,K) ,K=1,M) 
READ (25, *) 
WRITE(6,999) J, (FLUX ( J, K) , K=l , 6) 
WRITE (6, 999) J, (FLUX (J, K) ,K=997,1002) 
FORMAT (IX, 13 , 6E11 .4) 
CONTINUE 



CLOSE(UNIT:=25) 

RETURN 

END 



5A^^ABLE (ELOWER, EUPPER, N, NSP, IZLC^^J 



SUBROUTINE UNLOAD^TABLE (ELOWER, EUPPER, N, NSP, IZLO^^UP, TARGET, 
Sc CC,SPLOSS) 

C 

C Subroutine used by UPROPC to unload cross-section tables. 

IMPLICIT NONE 

INTEGER* 4 MARR, NELM, MCS , STAT, CREME96_OPEN 

PARAMETER {MARR=5000 , NELM=92 , MCS=10 ) 

REAL* 4 CC (NELM, NELM, MCS) 

REAL*4 SPLOSS (NELM, MCS) 

REAL* 4 ELOWER, EUPPER , ELOWER$ , EUPPER$ 

INTEGER*4 N, NSP , NABS , IZLO , IZUP, N$ , NSP$ , IZLO$ , IZUP$ , I , J, K 
CHARACTER*12 TARGET , TARGE T$ 
CHARACTER*80 CTABLEFILE , SPTABLEFILE 



DATA ELOWER$ , EUPPER$ , N$ , IZLO$ , IZUP$ , 
& TARGET$/0. ,0. ,0,0,0, ' '/ 



C FORMAT Statements 



100 FORMAT(1X,2(1PE10.4,2X) ,4{I5,2X) , A12 , 2X, IPEIO . 4 ) 



NABS=ABS (N) 

^ C 

^ C First, check standard table: 

□ C CTABLEFILE= ' CREME96 : CTABLE . STD ' 

Q c SPTABLEFILE='CREME96 :SPTABLE.STD' 

rU c IF (IZLO.GT.28 .or. IZUP. GT. 28) THEN 

Q c CTABLEFILE='CREME96 : CTABLE. XTD' 

Ly c SPTABLEFILE= ' CREME96 : SPTABLE . XTD' 

yk c ENDIF 

= . CTABLEFILE=' CTABLE. STD' 

U SPTABLEFILE= ' SPTABLE . STD ' 

ry IF (IZLO.GT.28 .or. IZUP. GT. 28) THEN 

CTABLEFILE= ' CTABLE . XTD ' 

^ SPTABLEFILE= ' SPTABLE . XTD' 

!™ ENDIF 



C OPEN {UNIT=36 , STATUS= ' OLD' , F I LE=CTABLEF I LE , READONLY, SHARED) 

Stat = creme96_open (ctablef ile, ' cr96tables' , 36 , ' old' ) 
READ (36, 100) ELOWER$ , EUPPER$ , N$ , IZLO$ , IZUP$ , NSP$ , TARGET$ 

CC WRITE (6 , 100) ELOWER$ , EUPPER$ , N$ , IZLO$ , IZUP$ , NSP$ , TARGET$ 



IF (ELOWER. EQ.ELOWER$ .AND. EUPPER . EQ . EUPPER$ .AND. 

$ NABS.EQ.N$ .AND. NSP.EQ.NSP$ .AND. 

& TARGET. EQ.TARGET$ .AND. 

& (IZLO$.LE.IZLO .AND. IZLO . LE . IZUP$ ) .AND. 

& (IZLO$.LE.IZUP .AND. IZUP . LE . IZUP$) ) THEN 



C Standard table contains the necessary information. 

C OPEN {UNIT=37 , STATUS= ' OLD' , F I LE=SPTABLEF I LE , READONLY, SHARED) 

Stat = creme96_open(sptablefile, ' cr96tables' , 37, 'old' ) 

READ(37, 100) 

CC READ (3 7,100) ELOWER$ , EUPPER$ , N$ , IZLO$ , IZUP$ , NSP$ , TARGET$ 

CC WRITE (6 , 100 ) ELOWER$ , EUPPER$ , N$ , IZLO$ , IZUP$ , NSP$ , TARGET$ 

C WRITE (6, 999) CTABLEFILE { 1 : 20 ) , SPTABLEFILE (1 : 20) , TARGET 

999 FORMATC Standard tables ' , A20 , Ix, A20 , 
& /,' of nuclear cross-sections', 

Sc ' in ' ,A12, ' used for transport calculation.') 



GOTO 500 
ENDIF 

C Check if appropriate tables exist in USER area: 

CLOSE (36) 

C OPEN{UNIT=36,STATUS='OLD' , FILE= ' USER : CTABLE . DAT' , READONLY , ERR= 5 0 ) 

Stat = creme96_open ( ' ctable . dat ' , ' user ' , 36 , ' old' ) 
if (stat .ne. 0) goto 50 

READ (36, 100) ELOWER$ , EUPPER$ , N$ , IZLO$', IZUP$ , NSP$ , TARGET$ 

IF (ELOWER.EQ.ELOWER$ ..AND. EUPPER . EQ . EUPPER$ .AND. 

$ NABS.EQ.N$ .AND. NSP.EQ.NSP$ .AND. 

5c TARGET. EQ. TARGET $ .AND. 

& {IZLO$.LE. IZLO .AND. IZLO . LE . IZUP$) .AND. 

& {IZLO$.LE.IZUP .AND. IZUP . LE . IZUP$) ) THEN 

C Standard table contains the necessary information. 

c OPEN (UNIT=37,STATUS=' OLD' , FILE= ' USER : SPTABLE . DAT' , READONLY, ERR=50 ) 

Stat = creme96_open ( ' sptable .dat ' , ' user' , 37 , ' old' ) 
if (stat .ne. 0) goto 50 
READ(37,100) 
WRITE (6, 998) TARGET 
998 FORMAT (' User tables (USER : CTABLE . DAT & SPTABLE.DAT) of 
& ' nuclear cross-sections' 

& /, ' in ' ,A12, ' used for transport calculation. ' ) 

GOTO 500 




ELSE 
50 CONTINUE 

C 

CLOSE (36) 
CLOSE (37) 
WRITE (6, 997) 
997 FORMAT (' Non-standard energy or shielding' 
& ' in transport calculation.', 

& /, ' Create new cross-section tables in USER area.') 

CALL CTABLE (ELOWER, EUPPER, NABS , NSP , IZLO, IZUP, TARGET) 
READ(36, 100) EUPPER$ , ELOWER$ , N$ , IZLO$ , IZUP$ , NSP$ , TARGET$ 
C OPEN (UNIT=37,STATUS=' OLD' , FILE= ' USER : SPTABLE . DAT ' , READONLY) 

Stat = creme96_open ( ' sptable .dat ' , ' user ' , 37 , ' old' ) 
READ(37, 100) 

ENDIF 

500 CONTINUE 

READ(36, 100) 
READ(37, 100) 
DO J=1,NABS 

READ (36, *) ( (CC(K, I, J) , K^IZLO$ , IZUP$) , I=IZLO$, IZUP$) 

READ (37 , * ) (SPLOSS (K, J) , K=IZLO$ , IZUP$) 
END DO 
CLOSE (UNIT=36) 
CLOSE (UNIT=37) 
RETURN 
END 





SUBROUTINE UNLOAD^IeADERS { INFILE , NHMAX, HEADER_LINF*fflNEMAX) 



IMPLICIT NONE 

CHARACTER* 80 INFILE , HEADER_LINE 
DIMENSION HEADER_LINE{1) 

INTEGER* 4 NHMAX , NHEADERS , VERSION_NUMBER, LINEMAX 
INTEGER*4 STAT, CREME96_OPEN 
INTEGER*4 INUNIT,J 
DATA INUNIT/4/ 

CALL CHECK_CREME96_VERSI0N (INFILE, VERSION_NUMBER) 
CALL CHECK_HEADER_LENGTH { INFILE , NHEADERS ) 

C OPEN(UNIT=INUNIT, FILE='USER: ' //INFILE, 

C & STATUS = ' OLD' , READONLY, SHARED) 

Stat = creme96_open (infile, ' user inunit, ' old' ) 

C By pass first line: 

IF {VERSION_NUMBER.GE. 102) READ ( INUNIT, 999 ) 
C Now store headers : 

LINEMAX=MIN (NHMAX , NHEADERS ) 

DO J=l, LINEMAX 

READ (INUNIT, 999) HEADER_LINE ( J) 
999 FORMAT (A80) 
ENDDO 

CLOSE (INUNIT) 



C 
C 
C 
C 



Reads lines of header information from file INFILE and 
returns LINEMAX lines in array HEADER_LINE . Maximum number 
of returned lines set by input NHMAX. 



RETURN 
END 



c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c- 

c 



SUBROUTINE UNLl 



I 



LET SPECTRUM (LETFILE, XL, FLUX, nWs) 



Subroutine to unload integral LET Spectrum from input file into 
array. Can handle either CREME96 format or the old CREME format 
(ie., two-column table of LET (in MeV-cm2/g) and particle fluxes 
(in particles/m2/s/sr) . ) CREME96 format is denoted by the 
suffix .LET or .DLT in the filename. 



Written by: 



Last update : 



Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 . nrl . navy . mil 

31 October 1996: modified to read differential LET files. 



IMPLICIT NONE 

INTEGER*4 K,N,NZ,NZT, I , NPTS , ILONG, MAXSPEC, STAT, CREME96_OPEN 

INTEGER* 4 I VER , J , NHEADER 

PARAMETER (MAXSPEC= 5000) 

CHARACTER*80 LETFILE, ILINE 

REAL*4 XL, FLUX,DUMFLUX,DUMXL,EL,EU 

DIMENSION XL (1), FLUX (1) 

DIMENSION DUMFLUX (MAXSPEC) , DUMXL (MAXSPEC) 



nJ 
□ 

: . : 



DO 1 1=1, MAXSPEC 

DUMFLUX (I) =0.0 
CONTINUE 

CALL CHECK_CREME96_VERSION (LETFILE, IVER) 

OPEN (UNIT=10,FILE=' USER: ' //LETFILE , STATUS =' OLD ' , READONLY) 
Stat = creme96_open(letfile, 'user' , 10, 'old' ) 
ILONG= INDEX (LETFILE, ' . ' ) 



IF (LETFILE (ILONG+1 : ILONG+3) 

& LETFILE ( ILONG+1 : ILONG+3 ) 

& LETFILE (ILONG+1 : ILONG+3) 

& LETFILE (ILONG+1 : ILONG+3) 



EQ.'LET' .or. 
EQ.'.let' .or. 
EQ.'DLT' .or. 
EQ.'dlt') THEN 



110 



IF ( IVER. GE. 102) THEN 
READ (10,*) NHEADER 
DO J=l, NHEADER 

READ(10,110) ILINE 

FORMAT (A80) 
ENDDO 
ENDIF 



200 
C 



read (10, *) el , eu, n, nz , nzt 
FORMAT ( (1X,6 (1PE10.4,2X) ) ) 

Calculate abscissae (LET values) 



DUMXL (1) =el 
DUMXL (N) =eu 
do 100 i=2,N-l 

DUMXL (i) =el* (eu/el) ** (float (i-1) /float (n-1) ) 




100 continue 

C Read blank line 

read (10, 110) ILINE 




read in the integral LET spectrum 
read (10, 200) (dumf lux (i) , i=l,n) 
CLOSE (10) 



ELSE 



C Two-column format (not CREME96 standard) 

N=l 

10 CONTINUE 

READdO, *,END=15) DUMXL ( N ) , DUMFLUX ( N ) 

N=N+1 

GOTO 10 
15 CONTINUE 

N=N-1 

CLOSE (10) 



ENDIF 



C 

C Editing of input LET spectrum removed by AJT 10-21-96. 



'± C 

Q 



NPTS=0 

DO 1000 K=1,N 



rU NPTS=NPTS+1 

□ XL(NPTS) =DUMXL(K) 

LU FLUX (NPTS) =DUMFLUX (K) 

U 1000 CONTINUE 



RETURN 
end 



DA^^RTIAL FLUX ( INFILE , IZMIN, IZMA3^^^] 



SUBROUTINE UNLOA^^ARTIAL_FLUX ( INFILE , IZMIN, IZMAX^KlNCUT, EMAXCUT, 
& BLOWER , EUPPER , M , I ZLO , I ZUP , 

* FLUX) 

C 

C From specified file INFILE unloads only elements IZMIN le Z le IZMAX 

C and returns the spectra in array FLUX. 

C 

IMPLICIT NONE 

INTEGER*4 MARR, NELM, STAT, CREME96_OPEN 
PARAMETER {MARR=5000 , NELM=92 ) 

REAL*4 FLUX (NELM, MARR) , FLUXDUM (NELM, MARR) , E (MARR) 
REAL* 4 ELOWER , EUPPER , EMINCUT , EMAXCUT , DE 
INTEGER*4 IZMIN, IZMAX, M, IZLO, IZUP, KZLO, KZUP, J, K 
INTEGER*4 KMIN, KMAX, KMINl , KMAXl 
INTEGER*4 IVER,NHEADER 
CHARACTER*80 INFILE, ILINE 



CALL CHECK_CREME96_VERSION ( INFILE, IVER) , 

C OPEN (UNIT=2 5 , STATUS= ' OLD ' , READONLY, FILE= ' USER : ' //INFILE) 

Stat = creme96_open (inf ile, ' user ' , 25 , ' old' ) 

IF ( IVER. GE. 102) THEN 
READ(25,*) NHEADER 
DO J=l, NHEADER 

READ (25, 110) ILINE 
110 FORMAT (A80) 
ENDDO 
ENDIF 

READ (25,*) ELOWER , EUPPER , M , KZLO , KZUP 

READ(25, *) 

DO 100 J=KZLO,KZUP 

READ (25, *) (FLUXDUM (J, K) ,K=1,M) 

READ (25, *) 
100 CONTINUE 

CLOSE(UNIT=25) 

IF ( IZMIN. EQ.O) THEN 
IZLO=KZLO 

ELSE 

IZLO=MAX ( IZMIN, KZLO) 

ENDIF 



IF (IZMAX. EQ.O) THEN 
I ZUP = KZUP 

ELSE 

I ZUP=MIN ( I ZMAX , KZUP ) 

ENDIF 

C Now check energy limits: 



DE= (EUPPER/ELOWER) ** ( 1 . / (M- 1 . ) ) 



IF ( ELOWER. GE. EMINCUT) THEN 



KMIN=1 

ELSE 

KMIN^l + IFIX (ALOG (EMINCUT/ BLOWER) /ALOG (DE) ) 
ENDIF 



IF (EUPPER.LE.EMAXCUT) THEN 
KMAX=M 

ELSE 

KMAX=2 + IFIX (ALOG (EMAXCUT/E LOWER) /ALOG (DE) ) 
IF (KMAX.GT.M) KMAX=M 
ENDIF 

KMIN1=MIN (KMIN, KMAX) 
KMAX1=MAX (KMIN, KMAX) 

DO 200 J=IZLO,IZUP 

DO 150 K=KMIN1 , KMAXl 

FLUX (J, K) =FLUXDUM (J, K) 
150 CONTINUE 
2 00 CONTINUE 

RETURN 
END 




SUBROUTINE UNLOAI^Pl^H { I P ATH , UPATH , TARGET, PATH, PS^^llN, PSTEPMAX, 
& PSTEP) 

C 

IMPLICIT NONE 
INTEGER* 4 IPATH,NSTEP 
CHARACTER* 12 TARGET 
* REAL* 4 UPATH, PATH, PSTEP , PSTEPMIN, PSTEPMAX, ALDEN 
DATA ALDEN/2. 702000/ 

C 

C NOTE: current version of UNLOAD_PATH supports Al shielding only. 

C 

I F ( TARGET . NE . ' ALUMINUM ' . and . TARGET . NE . ' aluminum ' ) THEN 
WRITE (6, 9999) 

9999 FORMATdX,' Specified shielding material unknovm. STOP') 

STOP 
ENDIF 

C Convert input UPATH (which can be in mils, cm, or g/cm2 Al) 

C to g/cm2 Al . 

C 

IF (IPATH.LT.O .or. IPATH.GT.2) THEN 
WRITE (6, 9998) IPATH 
9998 FORMATC® 04001 ABNORMAL TERMINATION: 

& /,lx, ' ERROR in UNLOAD_PATH: ', 

& /,lx, ' PATH UNITS STEERING CODE UNKNOWN: ',15, 

& /, Ix, ' STOP. ' ) 

STOP 
ENDIF 



IF ( IPATH. EQ.O) THEN 
C Already specified in g/cm2 

PATH=UPATH 
ELSEIF (IPATH. EQ. 2) THEN 
C Specified in cm: 

PATH=UPATH*ALDEN 
ELSEIF (IPATH. EQ.l) THEN 
C Specified in mils: 

PATH=ALDEN*2 . 54*UPATH/l000 . 
ENDIF 

C 

C Now set PSTEP for transport. 

PSTEP=PSTEPMIN 

100 CONTINUE 

NSTEP=PATH/PSTEP 
IF (NSTEP.GT.20) THEN 
PSTEP=PSTEP+0.10 
GOTO 100 
ENDIF 

IF ( PSTEP. GT. PSTEPMAX) PSTEP=PSTEPMAX 

C Allow for very short PATHS: 

IF ( PATH. LT. PSTEP) PSTEP=PATH 



RETURN 
END 



[jjj^PROTON SPECTRUM (PROTON FILE,E^^i; 



SUBROUTINE UNL(aBrPROTON_SPECTRUiyi ( PROTON_FILE , EN^LUX , NPTS ) 
C 

C Subroutine to unload proton Spectrum from input file into 

C array. Can handle either CREME96 format or the old CREME format 

C (ie., two-column table of energies (in MeV) and fluxes (in 

C protons/m2-s-sr-MeV) ) . CREME96 format denoted .fix, .tfx, or 

C . trp 

C 

C 

C Written by: Allan J. Tylka 

C Code 7654 

C Naval Research Laboratory 

C Washington, DC 20375-5352 

C tylka®crs2 . nrl . navy . mil 

C 

C Last update: 17 November 1997: add .trp option 

C 

C 

C 

C 
C 

IMPLICIT NONE 

CHARACTER*80 PROTON_FILE, ILINE 

INTEGER*4 MAXSPEC, N, NZ , NZT, MM, I , NPTS , ILONG, IZ 
O INTEGER*4 IVER, J, NHEADER, STAT , CREME96_OPEN 

^ REAL* 4 EN,FLUX,EL,EU,DUMFLUX 

U PARAMETER (MAXSPEC=5000) 

□ DIMENSION EN ( 1) , FLUX (1) ,DUMFLUX (MAXSPEC) 

fy CHARACTER* 3 SUFFIX 

[d CALL CHECK_CREME96_VERSION(PROTON_FILE, IVER) 

[ C OPEN (UNIT=10,FILE=' USER: ' //PROTON_FILE , STATUS= ' OLD ' , READONLY) 

Stat = creme96_open (proton_f ile, ' user ' , 10 , ' old' ) 
ILONG=INDEX (PROTON_FILE , ' . ' ) 
SUFFIX=PROTON_FILE (ILONG+1 : ILONG+3) 
CALL CAPITALIZE_STRING (SUFFIX, 3) 

Filename check re-written AJT 12-9-97 
IF (SUFFIX .EQ. 'TFX' .or. 

& SUFFIX .EQ. 'FLX' .or. 

& SUFFIX (1:2) .EQ. 'TR') THEN 



f y 



IF ( IVER. GE. 102) THEN 
READ (10,*) NHEADER 
DO J=l, NHEADER 

READ(10,110) ILINE 
110 FORMAT (A80) 

ENDDO 
ENDIF 



read (10, *) el , eu, n, nz , nzt 
IF (NZ.NE.l) THEN 

WRITE (6, 999) PROTON_FILE , NZ , NZT 



999 FORMATC® 09001 ABNORMAL TERMINATION: ', 

& /,lx,' ERROR IN UNLOAD_PROTON_SPECTRUM: ' , 

& /,lx,' Specified file: ', 

& /,lx,A80, 

& //Ix,' includes ',15,' .le. Z .le, ',15, 

& /,lx,' and contains no protons. STOP.') 



STOP 
ENDIF 

C 

C Calculate abscissae (energy values) 

EN(1) =:el 
EN(N) =eu 
do 100 i=2,N-l 

EN (i) =el* (eu/el) ** (float (i-l) /float (n-1) ) 
100 continue 
C 

DO 150 IZ=NZ,NZT 

C Read blank line 

read(10,110) ILINE 

c read in the flux 

read (10,*) (dumf lux (i) , i=l , n) 

IF (IZ.EQ.l) THEN 
DO 140 1=1, N 

FLUX ( I ) =DUMFLUX ( I ) 
O 14 0 CONTINUE 
ENDIF 



Q 150 CONTINUE 
n CLOSE (10) 

[ ELSE 

L; C Standard old-CREME two -column format 

^ 10 CONTINUE 

READdO, *,END=15) EN (N) , FLUX (N) 
N=N+1 
GOTO 10 
15 CONTINUE 
N=N-1 
CLOSE (10) 

ENDIF 

- Eliminate end-of-file zeroes from returned spectrum: 

NPTS=0 

DO 1000 1=1, N 

IF (FLUX(I) .GT.0.0) NPTS=I 
1000 CONTINUE 



RETURN 
end 




SUBROUTINE UNLOAD_^fflELDFILE (SHIELDFILE , 
& IUNITS,NSHIELD,UPATH, FRACSHLD) 

IMPLICIT NONE 
CHARACTER* 80 SHIELDFILE 

INTEGER*4 MAXSHIELD, lUNITS , NSHIELD, K, STAT, CREME96_OPEN 
REAL* 4 UPATH , FRACSHLD , TOTAL 
PARAMETER {MAXSHIELD=500 ) 

DIMENSION UPATH (MAXSHIELD) , FRACSHLD (MAXSH I ELD) 
INTEGER* 4 ISHDUNIT/15/ 
INTEGER* 4 IVER,NHEADER 
CHARACTER* 80 ILINE 

C 

CALL CHECK_CREME96_VERSION (SHIELDFILE, IVER) 

C OPEN (UNIT=ISHDUNIT, READONLY, SHARED, STATUS=: ' OLD' , 

C & FILE= ' USER :' //SHIELDFILE) 

Stat = creme96_open (shieldfile, ' user' , ishdunit, ' old' ) 

C 

IF (IVER.GT.O) THEN 

READdSHDUNIT, *) NHEADER 
DO K=l, NHEADER 

READdSHDUfNIT, 5) ILINE 
5 FORMAT (A80) 

□ ENDDO 
READdSHDUNIT,*) lUNITS 

□ ENDIF 

ni K=o 

TOTAL=0 
T7i 10 CONTINUE 

r: K=K+i 

IF (K.GT. MAXSHIELD) GOTO 100 

READdSHDUNIT, *,END=100) UPATH (K) , FRACSHLD (K) 

T0TAL=T0TAL+FRACSHLD (K) 

GOTO 10 
^ 100 CONTINUE 
H NSHIELD=K-1 

''''4 WRITE(6,999) NSHIELD 

999 FORMATC No. Shielding Bins = ',14) 

C Renormalize shielding fraction to unit integral: 

DO 2 00 K=l, NSHIELD 

FRACSHLD (K) =FRACSHLD (K) /TOTAL 
2 00 CONTINUE 

CLOSE (ISHDUNIT) 



RETURN 
END 



SUBROOTINE UNLO^^TABLE (ELOWER, EUPPER, M, IZLO, IZ^^ARGET, SP) 

IMPLICIT NONE 

REAL* 4 ELOWER,EUPPER 

INTEGER* 4 M, IZLO, I ZUP , NELM , MARR , STAT, CREME96_OPEN 

CHARACTER* 12 TARGET 

PARAMETER (MARR=5000 , NELM=92 ) 

REAL*4 SP(NELM,MARR) 

CHARACTER* 12 TARGET$ 

REAL*4 ELOWER$ , EUPPER$ 

INTEGER*4 M$ , IZLO$ , IZUP$ 

INTEGER* 4 J, K 

CHARACTER* 80 STABLEFILE 

C First, check standard table: 

C STABLEFILE= ' CREME96 : STABLE . STD' 

C IF (IZLO. GT. 28 .or. IZUP.GT.28) STABLE F I LE =' CREME96 : STABLE . XTD' 

STABLEFILE= ' STABLE . STD ' 

IF (IZLO. GT. 28 .or. IZUP.GT.28) STABLEFILE=' STABLE .XTD' 

c OPEN (UNIT=28 , F I LE= STABLE F I LE , STATUS = ' OLD' , READONLY, SHARED) 

Stat = creme96_open (stablef ile, ' cr96tables' , 28 , ' old' ) 
READ (28, 100) ELOWER$ , EUPPER$ , M$ , IZLO$ , IZUP$ , TARGET$ 

0 IF (ELOWER.EQ.ELOWER$ .AND. EUPPER . EQ . EUPPER$ .AND. M.EQ.M$ .AND. 
^ & TARGET . EQ . TARGET$ .AND. 

□ & (IZLO$.LE.IZLO .AND. IZLO . LE . IZUP$ ) .AND. 

□ & (IZLO$.LE.IZUP .AND. IZUP . LE . IZUP$ ) ) THEN 

nJ ^ 

Q C Standard table contains the necessary information. 

id 

12 C WRITE (6, 999) STABLEFILE ( 1 : 20 ) , TARGET 

1 999 FORMAT (Ix,' Standard table ',A20,' of stopping power', 
I, & 'in ',A12,' used',/,lx, ' for LET calculation.') 

GOTO 500 
f: ENDIF 

fl C 

C Check if appropriate table exists in user area: 
CLOSE (28) 

c OPEN (UNIT=2 8, FILE=' USER: STABLE. DAT' , STATUS= ' OLD' , READONLY, ERR=50 ) 

Stat = creme96_open('stable.dat' , 'user' ,28, 'old' ) 
if (stat .ne. 0) goto 50 

READ (2 8, 100) ELOWER$ , EUPPER$ , M$ , IZLO$, IZUP$ , TARGET$ 

IF (ELOWER.EQ.ELOWER$ .AND. EUPPER . EQ . EUPPER$ .AND. M.EQ.M$ .AND. 
& TARGET . EQ . TARGET$ .AND. 

& (IZLO$ .LE. IZLO .AND. IZLO . LE . IZUP$ ) .AND. 
& (IZLO$ .LE. IZUP .AND. IZUP . LE . IZUP$ ) ) THEN 

C 

C USER table contains the necessary information. 

WRITE (6, 998) TARGET 
998 FORMAT (' User table (USER: STABLE. DAT) of stopping power' 
& /, ' in ' ,A12, ' used for LET calculation. ' ) 



GOTO 500 



ELSE 




50 CONTINUE 

C 

C Create new STABLE.DAT in the users area: 

CLOSE (28) 
WRITE (6, 997) 

997 FORMAT {' Non-standard energy or material in LETSPEC calculation.', 
& /, ' Create new stopping power table in USER area.') 

CALL STABLE (ELOWER, EUPPER, M, IZLO, I ZUP, TARGET) 
c OPEN(UNIT=28,STATUS='OLD' , FILE= ' USER: STABLE . DAT' , READONLY) 

Stat = creme96_open('stable.dat' , 'user' ,28, 'old' ) 
READ (28,100) ELOWER$ , EUPPER$ , M$ , IZLO$ , IZUP$ , TARGET$ 

ENDIF 

500 CONTINUE 

READ(28, 100) 

DO J^IZLO$, IZUP$ 

READ (28,*) (SP(J,K) ,K=:1,M$) 

READ (28,*) 
ENDDO 
CLOSE (28) 

100 FORMAT { IX, 2 (1PE10.4,2X) ,3 (I5,2X) , A12 , 2X , IPEIO . 4 ) 
p 200 FORMAT( (1X,6 (1PE10.4,2X) ) ) 

n I RETURN 
^ END 



SUBROUTINE 




XSECT_FILE (XSECT_FILE,NSV, XV^) 




Subroutine to unload cross -section table from input file into 
array. Table is assumed to be in a two- column format, ordered 
according to increasing first-column value. 



Last update: 14 May 1996: 

add 'USER:' to input file name. 



IMPLICIT NONE 

CHARACTER* 8 0 XSECT_FILE 

INTEGER* 4 NSV, I , STAT, CREME96_OPEN 

REAL* 4 XV, YV 

DIMENSION XV(1),YV(1) 

OPEN (UNIT=10,FILE=' USER: ' //XSECT_F I LE , STATUS =' OLD' , READONLY) 
Stat = creme96_open(xsect_file, 'user' , 10, 'old' ) 
1=1 

10 CONTINUE 



Written by; 



Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 . nrl . navy . mil 



READdO, *,END=15) XV(I),YV(I) 
1 = 1 + 1 



15 



GOTO 10 
CONTINUE 
NSV=I-1 
CLOSE (10) 



RETURN 
end 



D^^TABLE {ELOWER, EUPPER, M, IZLO, IZ^^-J 



1 - * 



SUBROUTINE UNLOOT^TABLE {ELOWER, EUPPER, M, IZLO, I ZUPT-fARGET , PSTEP, 
& ZZ) 

C 

C Subroutine used by UPROPI to unload stopping power tables into array ZZ 

C 

IMPLICIT NONE 

INTEGER*4 MARR,NELM, STAT , CREME96_OPEN 
PARAMETER {MARR=5000 , NELM=92 ) 
REAL*4 ZZ(MARR,2,NELM) 

REAL*4 ELOWER , EUPPER , PSTEP , ELOWER$ , EUPPER$ , PSTEP$ 
REAL* 4 DELTA_PSTEP 

INTEGER*4 M, IZLO, IZUP , M$ , IZLO$ , IZUP$ , MM, J, K 
CHARACTER*12 TARGET, TARGE T$ 
CHARACTER* 80 ZTABLEFILE 

C FORMAT Statements 

100 FORMAT (IX, 2 (1PE10.4,2X) , 3 (I5,2X) , A12 , 2X , IPEIO . 4 ) 
200 FORMAT ( (IX, 6 (1PE10.4,2X) ) ) 

C First, check standard table: 

C ZTABLEFILE= ' CREME96 : ZTABLE . STD ' 

c IF (IZLO. GT. 28 .or. IZUP.GT.28) ZTABLE FI LE =' CREME9 6 : ZTABLE . XTD' 

3 ZTABLEFILE= ' ZTABLE . STD ' 

] IF (IZLO. GT. 28 .or. IZUP.GT.28) ZTABLEF I LE =' ZTABLE . XTD' 

I C OPEN (UNIT=35,FILE=ZTABLEFILE,STATUS=' OLD' , READONLY, SHARED) 

j Stat = creme96_open (ztablef ile, ' cr96tables ' , 35 , ' old' ) 

\ READ (35, 100) ELOWER$ , EUPPER$ , M$ , IZLO$ , IZUP$ , TARGET$ , PSTEP$ 

I DELTA_PSTEP=ABS ( PSTEP - PSTEP$ ) 

■ C TYPE *,' PSTEP, PSTEP$: ', PSTEP , PSTEP$ 

IF (ELOWER. EQ.ELOWER$ .AND. EUPPER . EQ . EUPPER$ .AND. M.EQ.M$ .AND. 
Sc TARGET. EQ.TARGET$ .AND. DELTA_PSTEP . LE . 0 . 001 .AND. 



& (IZLO$.LE. IZLO .AND. IZLO . LE . IZUP$ ) .AND. 
& (IZLO$.LE. IZUP .AND. IZUP . LE . IZUP$ ) ) THEN 

C 

''^ C standard table contains the necessary information. 

^ C WRITE (6, 999) ZTABLEFILE ( 1 : 20) , TARGET 

999 FORMAT (' Standard table ' ,A20, ' of stopping power', 

& ' in ',A12,' used for',/,' transport calculation.') 

GOTO 500 
ENDIF 

C 

C Check if appropriate table exists in USER area: 

CLOSE (35) 

c OPEN (UNIT=35,FILE=' USER: ZTABLE. DAT' , STATUS= ' OLD' , READONLY, ERR=50) 

Stat = creme96_open( ' ztable.dat' , 'user' , 35, 'old' ) 
if (stat .ne. 0) goto 50 

READ (35, 100) ELOWER$ , EUPPER$ , M$ , IZLO$ , IZUP$ , TARGET$ , PSTEP$ 
DELTA_PSTEP=ABS ( PSTEP- PSTEP$) 

IF (ELOWER. EQ.ELOWER$ .AND. EUPPER . EQ . EUPPER$ .AND. M.EQ.M$ .AND. 
& TARGET. EQ. TARGET $ .AND. DELTA_PSTEP . LE . 0 . 001 .AND. 
& (IZLO$.LE.IZLO .AND. IZLO . LE . IZUP$ ) .AND. 
& (IZLO$.LE.IZUP .AND. IZUP . LE . IZUP$ ) ) THEN 



^^the necessary information. 



1 User table contanTlP^the necessary information. 

WRITE {6, 998) TARGET 
998 FORMAT (' User table (USER : Z TABLE .DAT) of stopping power' 
& /,' in ',A12,' used for transport calculation.') 

GOTO 500 



ELSE 
50 CONTINUE 

C 

C Create new ZTABLE.DAT in the users area: 

CLOSE (35) 
WRITE (6, 997) 

997 FORMAT (' Non-standard energy or shielding or PSTEP' 
& ' in transport calculation.', 

& /,' Create new stopping power table in USER area.') 

CALL ZTABLE (ELOWER, EUPPER, M, IZLO, I ZUP, TARGET, PSTEP) 
C OPEN(UNIT=35,STATUS='OLD' , FILE= ' USER : ZTABLE . DAT' , READONLY) 

Stat = creme96_open ( ' ztable . dat ' , ' user ' , 35 , ' old' ) 
READ (35,100) ELOWER$ , EUPPER$ , M$ , I ZLO$ , I ZUP $ , TARGET$ , 

& PSTEP$ 

ENDIF 

CONTINUE 
READ(35, 100) 
DO J=IZLO$, IZUP$ 

READ (35, *) (ZZ (K, 1, J) ,K=1,M$) 
READ(35, 100) 

READ (35, *) (ZZ (K,2, J) ,K=1,M$) 
READ(35, 100) 
END DO 

CLOSE(UNIT=3 5) 

RETURN 
END 




SUBROUTINE UPR( 




(INPUT_FLUX, 
ELOWER , EUPPER , M , I ZLO , I ZUP , 
NDUM , NS P , PATH , PSTEP , TARGET , 
OUTPUT FLUX) 




Sc 



C 

^*************************************** 

C 

C This module evaluates nuclear transport, by calculating a numerical solution 

C to a one dimensional continuity equation, taking into account both 

C ionization energy loss (in the continuous -slowing -down approximation) and 

C nuclear fragmentation. 

C 

C This code is based on UPROP, originally written by John R. Letaw of Severn 
C Communications Corporation, working under contract to the Gamma Ray and 
C Cosmic Ray Astrophysics Branch of Naval Research Laboratory in 1989. 
C 

C See "UPROP: A Heavy-Ion Propagation Code", by J.R. Letaw, SCC Report 89-02, 

C 31 August 1989. 

C 

C Adapted for use with CREME96 by AJT. Last Update 05 June 1996 

C 

C Important Parameters 
C 

C MARR Maximum number of logarithically- spaced energy bins in spectrum 

C NELM Maximum atomic number of elements to be transported (<= 109) 

C NDUM Flag determining treatment of nuclear spallation reactions 

C If NDUM=0 does not include nuclear spallation 

C NDUM<0 does not follow nuclear fragments 

C |ndum|=1 uses energy- independent cross sections 

C |NDUM|>1 uses cross sections calculated at N equally- spaced 

C energies and interpolated between 

C PATH Total propagation pathlength in g/cm**2 

C PSTEP A small pathlength over which 2 nuclear fragmentations are 

C unlikely, typically 0.1 g/cm**2. 

C TARGET Name of the target shielding material 

C INFILE File containing the heavy- ion energy spectrum {<= 40 bytes) 

C OUTFILE File containing the energy spectrum after transport (<= 40 bytes) 

C 

C Important variables 
C 

C FLUX working array contains the energy spectra of up to NELM elements 
C specified at up to MARR energies 



IMPLICIT NONE 
INTEGER* 4 MARR, NELM 
PARAMETER (MARR=5000 , NELM=92 ) 

REAL* 4 INPUT_FLUX (NELM, MARR) , OUTPUT_FLUX (NELM, MARR) 

REAL* 4 FLUX (NELM, MARR) 

REAL*4 ELOWER, EUPPER, PATH, PSTEP 

INTEGER*4 M,N,NDUM, IZLO, IZUP, J,K,NSP 

CHARACTER TARGET* 12 



C 



C 



C 



Copy input fluxes to working array: 
DO 20 J=IZLO, IZUP 



DO 10 K=1,M 



FLUX (J, K) =INPUT_FLUX (J, K) 



10 
20 



CONTINUE 
CONTINUE 





Special case for very thin shield (0.20 g/cm2 = 29.16 mils Al) : 
Added by AJT, per JHA suggestion, 6-5-96 

IF (PATH. LT. 0.20) THEN 

CALL THIN_SHIELD (ELOWER, EUPPER,M, IZLO, I 2UP, TARGET, PATH, FLUX) 

ELSE 
N=NDUM 

IF (PATH. LT. 0.1) N=0 
IF (N.NE.O) THEN 

Alternate ionization loss and fragmentation using the pathlength 
PSTEP until PATH is accumulated. 

DO J=l,INT(PATH/PSTEP+0.5) 

CALL UPROPI (ELOWER, EUP PER, M, IZLO, I ZUP, TARGET , PSTEP , FLUX) 

CALL UPROPC ( ELOWER , EUP PER , M , N , NS P , I ZLO , I ZUP , TARGET , PSTEP , FLUX ) 

END DO 



Do ionization loss (only) using the pathlength PSTEP until PATH 
is accumulated 

DO J=l, INT(PATH/PSTEP+0.5) 

CALL UPROPI (ELOWER, EUPPER,M, IZLO, I ZUP , TARGET, PSTEP , FLUX) 
END DO 



Copy transported energy spectra to output arrays : 

DO 200 J=IZLO,IZUP 

DO 100 K=1,M 

OUTPUT_FLUX ( J, K) =FLUX ( J, K) 

CONTINUE 
CONTINUE 



ELSE 



ENDIF 



ENDIF 



RETURN 
END 



0^lfeLOWER,EUPPER,M,N,NSP, I2L0, IZI^^\ 



SUBROUTINE UPROMifE LOWER, EUPPER , M, N, NSP , I2L0, IZUFTfARGET, 
& PSTEP,FLUX) 
C******** ********************************************* ***** 

C SUBROUTINE UPROPC in Module UPROP.FOR 
C 

C Nuclear spallation subroutine. Determines the attenuation of a heavy-ion 
C energy spectrum from spallation reactions in passage through shielding 
C material. Initiates creation of an auxiliary data file (CTABLE.DAT) if 
C a suitable one does not already exist . 
C Modified by A.F. Barghouty 3-25-96 

C* ************************************************************************ * 

C Parameters 

C 

C MARR Maximum number of logarithically- spaced energy bins in spectrum 
C NELM Maximum atomic number of elements to be transported (<= 109) 
C MCS Maximum number of energies at which cross section data are 

C defined 

C ELOWER Lower energy bound of input and output spectra (>= 0.1 MeV) 

C EUPPER Upper energy bound of input and output spectra (<= 100000 MeV) 

C M Number of logarithmically equally- spaced energy bins (<= MARR) 

C N Number of energies at which cross section data are defined (<= MCS) 

C I2L0 Least atomic number of elements transported {>= 1) 

C IZUP Greatest atomic number of elements transported {<f 109) 

C TARGET Name of the target shielding material (<= 12 bytes) 

O C PSTEP A small pathlength over which 2 nuclear fragmentations are 
C unlikely, typically 0.1 g/cm**2. 

Q C FLUX Contains the energy spectra of elements IZLO through IZUP at 

Q C M energies 

m c 

C Important variables 
C 

C E Energy at each M-point grid (spectrum grid) 

C ECS Energy at each N-point grid (cross section grid) 

C VC Version number of current spallation cross section data file 

C (CTABLE.DAT) 

C FT Temporary flux vector used in calculating secondary spectra 

C CC Partial and total cross section data computed by SPROP and stored 

C in CTABLE.DAT. First index is product Z; second index is target 

C 2; third index is index in N-point energy grid. 

C CCT Temporary array for holding cross sections at current M-point 

C energy grid. 

C REL Factor for normalizing energy to minimum energy on the grid 

C FUL Factor relating energy ratio to number of bins on the grid 
C************************************************************************** 

PARAMETER (MARR=5000 , NELM=92 , MCS=10 ) 



REAL*4 FLUX (NELM, MARR) , CC (NELM, NELM, MCS) , E (MARR) , ECS (MCS) 
REAL*4 FT (NELM) , CCT (NELM, NELM) , SUMl (NELM) , SUM2 (NELM) 
REAL*4 SPLOSS (NELM, MCS) , SPLT (NELM, MARR) , dFLUX (NELM, MARR) 
REAL*4 FACTOR (NELM) , TFLUXl (NELM) , TFLUXO (NELM) 
CHARACTER* 12 TARGET , TARGET$ 
DATA IENT/0/ 

IF (lENT.EQ.O) THEN 
IENT=1 

CALL UNLOAD_CTABLE (ELOWER, EUPPER, N,NSP, IZLO, IZUP, TARGET, 
& CC, SPLOSS) 

ENDIF 



NABS=ABS (N) 



Compute energies associated with flux points 

REL=1. /ELOWER 

FUL=1 . /LOG (EUPPER/ELOWER) 

DE= (EUPPER/ELOWER) ** ( 1 ./ (FLOAT (M) -1. ) ) 

E(l) =ELOWER 

DO 1=2, M-1 

E(I)=E{I-1)*DE 
END DO 
E (M) =EUPPER 

Compute energies associated with cross sections 

IF (NABS.GE.2) THEN 

DE= (EUPPER/ELOWER) **(!./ (FLOAT (NABS) -1 . ) ) 

ECS(1)=EL0WER 

DO I=2,NABS-1 

ECS (I) =ECS (I-l) *DE 
END DO 

ECS (NABS) =EUPPER 
END IF 

Perform fragmentation for each particle energy 
DO 1=1, M 

Perform linear interpolation of cross 
section matrix appropriate for current energy 

[Interpolation debugged -for large II- 3/23/1996] 

IF (NABS.GE.2) THEN 

XI=1.+ (NABS-1 . ) *LOG (E (I) *REL) *FUL 
II=INT(XI) 

IF (XI. GE. NABS) THEN 

DELTA=1./ (ECS (NABS) -ECS (NABS-1) ) 
ELSE 

DELTA=1. / (ECS (II + l) -ECS (II) ) 
ENDIF 

IF(I.LT.M) THEN 

F1X=DELTA* (E(I) -ECS (II) ) 

F2X=DELTA* (ECS (II+l) -E (I) ) 
END IF 

DO J=IZLO, IZUP 
DO K=IZLO,IZUP 
IF(I.EQ.l) THEN 

CCT{J,K) =CC(J,K,1) 
SPLT(J, I) =SPLOSS (J, 1) 
END IF 

IFd.LT.M) THEN 

CCT (J, K) =F1X*CC (J, K, II+l) +F2X*CC ( J, K, II) 
SPLT (J, I) =F1X*SPL0SS (J, II+l) +F2X*SPL0SS (J, II) 

END IF 

IF(I.EQ.M) THEN 

CCT{J,K) =CC{J,K,NABS) 
SPLT (J, I) =SPLOSS (J, NABS) 
END IF 
END DO 
END DO 




ELSE 

DO J=IZLO,IZUP 
DO K=IZLO, IZUP 

CCT(J,K)=CC(J,K,1) 
SPLT(J, I) =SPLOSS (J, 1) 
END DO 
END DO 
ENDIF 

C 

IF (N.GT.O) THEN 



C If N > 0, compute fragmentation losses and gains 

C Form a temporary flux vector and multiply by PSTEP 

C Secondaries (only) are computed from new vector 

DO J=IZLO, IZUP 

FT (J) =FLUX (J, I) *PSTEP 
END DO 

C 

C Modify flux according to secondary production (includes 

C all losses and gains) 

DO J=IZLO,IZUP 
P DO K=IZLO,IZUP 

yg FLUX (J, I ) =FLUX (J, I ) +CCT (J, K) *FT (K) 

□ END DO 

Q IF (FLUX{J, I) .LT.l.E-20) FLUX ( J, I ) ==0 . 

nj END DO 

n ELSE IF (N.LT.O) THEN 

I C If N < 0, compute only fragmentation loss 



L.. DO J=IZLO,IZUP 

:^ FLUX (J, I) =FLUX(J, I) * (l.+CCT(J, J) *PSTEP) 

9^ IF (FLUX(J, I) .LT.l.E-20) FLUX(J,I)=0. 

^ END DO 

"J ENDIF 
END DO 

C 

C Compute new flux taking into account energy losses due to 

C fragmentation: (Sept. 1993) 

C 

IF(NSP.EQ.l) THEN 
IF(IENT.EQ.O) THEN 
IENT=1 

WRITE (6, 9999) 

9999 FORMATdx,' UPROPC : Straight - ahead approx. NOT used.') 

END IF 

C 

DO I=IZLO,IZUP 

SUM1(I)=0. 

DO J=1,M 

SUMl (I) =SUM1 (I) +FLUX (I, J) *E (J) 

END DO 
END DO 

C 

DO I^IZLO,IZUP 




c 
c 



DO J=1,M 
. dFLUX(I,J)=0. 

IF(J.EQ.l) THEN 
dEN=l./ (E(2).-E(l) ) 

dFLUX (1,1) =dEN* (SPLT (1,1) *FLUX (1,2) +SPLT (1,2) *FLUX (1,1) . 
& -2.*FLUX(I,1)*SPLT(I,1) ) 

ELSE IF(J.EQ.M) THEN 
dEN=l./ (E(M) -E(M-l) ) 

dFLUX (I, M) =dEN* (2 .*FLUX(I,M) *SPLT(I,M) 
Sc -SPLT(I,M-1) *FLUX(I,M) - SPLT (I, M) *FLUX(I,M-1) ) 

ELSE 

dEN=l./ (E(J+1) -E(J-l) ) 

dFLUX (I, J) =dEN* ( (SPLT(I, J+1) -SPLT (I, J- 1) ) *FLUX(I, J) 
& +{FLUX(I, J+1) - FLUX (I, J- 1) ) *SPLT(I, J) ) 

END IF 

IF(ABS(dFLUX(I, J) ) .LT.l.E-20) dFLUX (I, J) =0. 
FLUX ( I , J) =FLUX ( I , J) +dFLUX ( I , J) *PSTEP 
IF(FLUX{I,J) .LT.l.E-20) FLUX(I,J)=0. 

C 

p END DO 

.r1 END DO 

DO I = IZLO, IZUP 
si SUM2(I)=0. 

DO J=1,M 

H suiyi2 (I) =suiyi2 (i) +flux(i, j) *e(j) 

r: END DO 

^ END DO 

' C 

1^' C Normalization : 

;U DO I=IZLO,IZUP 

W ZER0=ABS(1.-SUM1(I)/SUM2(I) ) 

M IF(ZERO.GT. . 01) THEN 

C TYPE * , ' ' 

%J C TYPE *** Normalization...! ***' 

C TYPE * , ' ' 

END IF 
END DO 

C 

END IF 
RETURN 
END 



SUBROUTINE UPROP^ELOWER, EUPPER, M, IZLO, IZUP, TARGE' 
& PSTEP,FLUX) 



C********* ********************* ******* *************** ********* 

C SUBROUTINE UPROPI in Module UPROP.FOR 

C 

C Ionization loss subroutine. Determines the attenuation of a heavy-ion 
C energy spectrum from ionization losses in passage through shielding 
C material. Initiates creation of an auxiliary data file { ZTABLE.DAT) if 
C a suitable one does not already exist. 

Q-k* * * ******************************************************************** 

C Parameters 
C 

C MARR Maximum number of logarithically-spaced energy bins in spectrum 

C NELM Maximum atomic number of elements to be transported 

C ELOWER Lower energy bound of input and output spectra (<= 0.1 MeV) 

C EUPPER Upper energy bound of input and output spectra (>= 100000 MeV) 

C M Number of logarithmically equally- spaced energy bins {<= MARR) 

C IZLO Least atomic number of elements transported (>= 1) 

C IZUP Greatest atomic number of elements transported (<= 109) 

C TARGET Name of the target shielding material (<= 12 bytes) 

C PSTEP A small pathlength over which 2 nuclear fragmentations are 

C unlikely, typically 0.1 g/cm**2. 

C FLUX Contains the energy spectra of elements IZLO through IZUP at 

C M energies 

C 

C Important variables 
C 

C FLUX2 Temporary vector containing the energy spectrum of a single 

C element 

C ZZ Range and stopping power data computed by ZPROP and stored in 

C ZTABLE . DAT 

C REL Factor for normalizing energy to minimum energy on the grid 

C FUL Factor relating energy ratio to number of bins on the grid 
C************************************************************************ 

IMPLICIT NONE 
INTEGER* 4 MARR, NELM 
PARAMETER ( MARR= 5000, NELM= 9 2 ) 

REAL*4 FLUX (NELM, MARR) , ZZ (MARR, 2 , NELM) , E (MARR) , FLUX 2 (MARR) 
CHARACTER* 12 TARGET 

INTEGER*4 IENT,M, IZLO, IZUP, I, J,K,KK 
REAL* 4 ELOWER , EUPPER , PSTEP , REL , FUL , DE , XK 
DATA IENT/0/ 

IF (lENT.EQ.O) THEN 
IENT=1 

CALL UNLOAD_ZTABLE (ELOWER, EUPPER, M, IZLO, IZUP, TARGET, PSTEP, ZZ) 
ENDIF 

C Compute new flux 



REL=1. /ELOWER 

FUL=1 . /LOG (EUPPER/ELOWER) 

DE= (EUPPER/ELOWER) ** (1, / (M-1. ) ) 

E(1)=EL0WER 

DO 1=2, M-1 

E(I)=E(I-1)*DE 
END DO 
E(M) =EUPPER 



DO J=IZLO,IZUP 
DO K=1,M 

XK=1 . + (M-l . ) *LOG (ZZ (K, 1 , J) *REL) *FUL 

KK=INT{XK) 

IF (XK.GE.M) THEN 

FLUX2 (K) = { (ZZ (K, 1, J) -E (M-1) ) *FLUX (J,M) + 
& {E{M) -ZZ(K,1, J) ) *FLUX(J,M-1) ) / (E (M) -E(M-l) ) 

ELSE 

FLUX2 (K) = { (ZZ (K, 1, J) -E (KK) ) *FLUX (J,KK+1) + 
& (E (KK+1) -ZZ (K, 1, J) ) *FLUX(J,KK) ) / (E (KK+l) -E(KK) 

ENDIF 

FLUX2 (K) =FLUX2 (K) *ZZ (K, 2 , J) 
IF (FLUX2 (K) .LT.l.E-20) FLUX2(K)=0. 
END DO 
DO K=1,M 

FLUX { J, K) =FLUX2 (K) 
END DO 
END DO 
RETURN 
END 



Module: VAX ROUTINES 



Logical Names and Environment Variables serve the same purpose, 
but are handled differently, on the two CREME96 platforms (VAX and 
PC respectively) . There are also differences between the two file 
OPEN statements . To enable platform independance where fully 
specified filenames and where file opens are used in' the higher 
level CREME96 code, two versions exist of the routines to perform 
these tasks. When an executable is being created, it is the 
responsibility of the person performing the link to ensure that the 
appropriate set of routines is used for the current build. 



Three plat form- DEPENDANT routines exist: 



CREME96_FULL_FILENAiyiE 
CREME96 OPEN 



creates fully-specified filename 
performs a file OPEN on full filename 



CHECK FILE. FOR 



Added 6/8/97 

because VAX version contains LIB$SPAWN 
REMOVED 11/18/97 by AJT 



SHOW DIRECTORY. FOR 



Added 11/18/97; contains LIB$SPAWN 



These routines reside in the following 2 physical files: 



VAX_ROUTINES . FOR 
PC ROUTINES. FOR 



used for a VAX build (this file) 
used for a PC build 



*********************************** ************* 



Integer function creme96_open (filename, path, unit , status) 



FILENAME : 
PATH: 



The non-fully specified name of the target file. 

Contains the VMS logical pointing to directory 
where file does, or will exist. 



UNIT: 



The logical unit to be associated with the file. 
Must be defined at the time of the function call 
(one will not be assinged by this routine) . 



STATUS : 



Contains either OLD, for existing file, or 
NEW, to create a file. 



Calling example: 

STAT = creme96_open (' input . dat' creme96 inunit old' ) 



Success is indicated by a ZERO return value. Otherwise, the 
return value will contain the FORTRAN error code. 



IMPLICIT NONE 



^^^ile, creme96 full f ilename, lin^^^ 



character*80 ^^ile, creme96_f ull_f ilename, line^ 
character* (*) filename 
character*!*) path 
integer unit,ios 
character* ( * ) status 

C WRITE (*,*) 'IN OPEN... FILENAME: FILENAME,' PATH: ' , PATH 

file = creme96_full_filename (filename, path) 

if (status(l:l) .eq. 'o' .or. status{l:l) .eq. '0') then 
c Old files are only opened for READ (no APPEND in CREME96) . 

c Any file opened for READ will be opened SHARED. 

open (unit=uni t , f ile=f ile , status= ' old' , 
& READONLY, SHARED, iostat=ios , err=199 ) 



c DEBUG 



c read (unit , 99) line 

c99 format (a80) 

c write (*,*)' First line in file: ' , line 
else 

c New file to be created. WRITE and NOSHARE are default. On the PC, 

c we must open with REPLACE instead of NEW, in case a file already 

c exists of this name (as it is our intention to write over it) . If 

c one doesn't exist, REPLACE acts the same as NEW. 

OPEN (UNIT=unit, f ile=f ile, status=' new' , 
Sc iostat=ios, err=199) 

c DEBUG 

c write (*,*) 'Writing test line to new file...' 

c write (unit ,*)' Test line' 

endif 

199 creme96_open = ios 

return 



end 

c 

c********* **************************** **********^ 
c 

Character*80 function creme96_f ull_f ilename (filename , path) 



c The variable PATH contains the name of the VMS logical, which 

c in turn points to the directory path of the target file, 

c This routine appends the logical name to the bare filename. 

IMPLICIT NONE 
character* (*) filename 
character* (*) path 



C WRITE ( * , * ) 'IN FULL . . . FILENAME : ' , FILENAME , ' PATH : ' , PATH 



creme96_full_f ilename = path// ':' //filename 




WRITE ( * , * ) '^BE_FILENAME : ' , CREME96_FULL_FIL 

return 
end 



9t 

lTBIame 



c* ******************************************************* ************ 
SUBROUTINE SHOW DIRECTORY {JF I LETYPE) 



C 
C 
C 



VAX-specific routine. 

INTEGER*4 JFILETYPE , ISTAT 
LOGICAL LIBSPAWN 



9010 



IF (JFILETYPE.EQ.O) THEN 
WRITE (6, 9010) 

FORMAT (Ix,' Here is the directory of your current USER area:'! 
ISTAT=LIB$SPAWN('DIR USER:*.*') 



9011 



ELSEIF (JFILETYPE.EQ.l) THEN 
WRITE (6, 9011) 

FORMAT (Ix,' Here are the .TRP files in your current USER area:') 
ISTAT=LIB$SPAWN('DIR USER : * . TR* ' ) 



tfl 9012 



ELSEIF (JFILETYPE.EQ;2) THEN 
WRITE (6, 9012) 

FORMAT (Ix,' Here are the .GTF files in your current USER area:') 
ISTAT=LIB$SPAWN('DIR USER:*.GT*') 



z : 
E r : 



ru 



ELSEIF (JFILETYPE.EQ.3) THEN 
WRITE (6, 9013) 

9013 FORMATdx,' Here are the . FLX files in your current USER area:') 
ISTAT=LIB$SPAWN('DIR USER:*. FLX') 
WRITE (6, 9014) 

ISTAT=LIB$SPAWN('DIR USER:*.TFX') 
WRITE (6, 9011) 

ISTAT=LIB$SPAWN('DIR USER:*.TR*') 



ELSEIF (JFILETYPE.EQ.4) THEN 
WRITE (6, 9014) 

9014 FORMATdx,' Here are the .TFX files in your current USER area:' 
ISTAT=LIB$SPAWN { ' DIR USER : * . TFX ' ) 
WRITE (6, 9013) 

ISTAT=LIB$SPAWN{'DIR USER:*. FLX') 
WRITE (6, 9011) 

ISTAT=LIB$SPAWN{'DIR USER:*.TR*') 



9015 



ELSEIF (JFILETYPE.EQ.5) THEN 
WRITE (6, 9015) 

FORMAT (Ix,' Here are the .LET files in your current USER area:'! 
ISTAT=LIB$SPAWN('DIR USER:*. LET') 



9016 



ELSEIF (JFILETYPE.EQ.6) THEN 
WRITE (6, 9016) 

FORMATdx,' Here are the .DLT files in your current USER area:') 
ISTAT=LIB$SPAWN{'DIR USER:*. DLT') 



ELSEIF (JFILETYPE.EQ. 7) THEN 
WRITE (6, 9017) 

9017 FORMATdx,' Here are the . SHD files in your current USER area:') 
ISTAT=LIB$SPAWN{'DIR USER:*. SHD') 




ELSEIF {JFILETYPE.EQ.8) THEN 
WRITE (6, 9018) 

9018 FORMATdx,' Here are the .XSD files in your current USER area:') 
ISTAT=LIB$SPAWN('DIR USER:*. XSD') 

ENDIF 

WRITE (6, 9999) 
9999 FORMAT {/) 
RETURN 
END 




c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c- 

c 



REAL*4 FUNCTreir WEIBULL (ONSET, WIDTH, POWER, ASYmI 



Returns value of Weibull cross-section evaluated at abscissa E 
This function can be used for either heavy- ion or proton 
cross -sections; but the units are different in each case. 

Input parameters of Weibull fit: 

0= onset (in MeV for proton; in MeV-cm2/mg for heavy ion LET) 

W= width (as above) 

P= power (dimensionless exponent) 

A=: asymptote (in lOE-12 cm2/bit for protons cross -sections ; 

in square microns/bit for heavy- ion cross-sections) 
E= absicissa (in MeV for protons; in MeV-cm2/mg for heavy ion LET) 

Output: SEU cross-section (same units as asymptote) 



Written by: 



Last update: 



Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 . nrl . navy . mil 

29 March 1996 



IMPLICIT NONE 

REAL* 4 E , ONSET , Y , WIDTH , POWER , ASYMPTOTE 



WEIBULL=0 

IF (E.LT. ONSET) RETURN 

Y = ( (E-ONSET) /WIDTH) **POWER 

Y=1.0-exp(-y) 

WE I BULL = AS YMPTOTE * Y 

IF ( WEIBULL. LT. 0. ) WEIBULL=0. 

RETURN 

END 



SUBROUTINE YIE; 



IZ, lA, JZ, JA, EJ, QJ) 



C 

c 

c. . . 

C... Silberberg&Tsao Semiempirical Cross Sections Routines 

C. . . Notation: 

C... The S&T routines give the inelastic cross section QJ (in mb) 

C... for the reaction; 

C... (IZ,IA) + proton --> (JZ,JA) at energy EJ (in MeV/Nucleon) , 

C... on the basis of a set of semiempirical formulae. 

C... Inputs: IZ - Atomic number of incoming nucleus 
^- • • - Atomic weight of incoming nucleus 

^' • * J2 - Atomic number of secondary nucleus 

- Atomic weight of secondary nucleus 
^'** " Amount of energy per nucleon of secondary nucleus 

C... OUTPUT: QJ - Inelastic cross section of reaction 

C. . . References in commented lines are from: 

C... [1] Silberberg, R. & Tsao, C. H. 1973, Astrophys . J. Suppl . , 

^' * ' , , 25, pp. 315 - 333. 

C... [2] Silberberg, R. & Tsao, C. H. 1973, Astrophys. J. Suppl . , 

^" ' r . PP- - 368. 

C... [3] Silberberg, R., Tsao, C. H. & Letaw, J. R., 

Astrophys. J. Suppl., 58, pp. 873 - 881. 
C. . . Another useful reference is: 

C... Silberberg, R. & Tsao, C. H. 1990, Phys. Rep., 191, 351. 

*** Rewritten November 1995 *** 
C... Majority of comments written by Mark E. Mattson, 
C... March - April, 1996, e-mail: mattson@vpihe4.phys.vt.edu 

C... Routines linked: 

C... (1) PXN; for JZ = IZ+1 but JA=IA (i.e., pick-up reactions) 

C... (2) YIELDl (through 4 are spallation reactions); for JZ <= 4 

C... (3) YIELD2; for JZ >= 5 and 5 <= IZ <= 16 ' " 

C... (4) YIELD3; for JZ >= 5 • and 17 <= IZ <= 20 

C... (5) YIELD4; for JZ >= 5 and 21 <= IZ <= 92 

C... (6) CORRECTIONS; for various energy and/or structure-related 

correction factors to spallation yields. 



IMPLICIT NONE 
REAL* 4 EJ,QJ 
INTEGER*4 IZ,IA,JZ,JA 
REAL*4 Q1,Q2,Q3,Q4,EXPF 

REALM QR, QE, QF, QH, FE, FF, FA, FZ, CJ, PN, GA, ANZJ, AA, AE, AC, EC 

LOGICAL NULL , NOT^CONSERVED , OUT_OF_RANGE , 
& NON_PICKUP , PICKUP, REJECTED 

LOGICAL REGIONl,REGION2,REGION3 

COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,ANZJ,AA,AE,AC,EC 
QJ = 0 

C. . . Definitions : 

C... This is in case the input indicates the secondary nucleus is exactly 



the same as t!^^^nitial nucleus . 
NULL = IZ*IA.EQ. JZ*JA 

If the change in the atomic number of the nuclei is greater than the 
change in atomic number, then there's something wrong with the input. 
NOT_CONSERVED = ( (IZ-JZ) .GT. (lA-JA) ) .OR. NULL 

If the incoming atomic weight is less than the secondary atomic weight, 
or if the incoming atomic number is greater than 92 (uranium) , of if 
the incoming atomic number indicates hydrogen or helium, we're not 
interested in it. 
OUT_OF_RANGE = lA.LT.JA .OR. IZ.GT.92 .OR. IZ.LE.2 

If the secondary atomic number is 2 or more greater than the incoming 
atomic number, or if the number of neutrons in the secondary nucleus 
is greater than the number of neutrons in the incoming nucleus, or if 
the secondary nucleus is that of hydrogen, we're not interested in it. 

NON_PICKUP = (IZ-JZ) .LT.-l .OR. ( ( lA- IZ) - ( JA- JZ) ) . LT . 0 
& .OR. JZ.LE.l 

If the atomic number of the secondary is 1 greater than the atomic 
number of the incoming and if the incoming atomic weight is at least 
as great as the secondary atomic weight, we ARE interested in it, but 
only as a (p,pxn) "pick-up" reaction. 
PICKUP = (IZ-JZ) .EQ. -1 .AND. lA.GE.JA 

Regions of applicability as determined by the incoming nucleus: 
REGIONl = IZ.GE. 5 .AND. IZ.LE.16 I Nuclei for Boron through Sulphur 
REGI0N2 = IZ.GE. 17 .AND. IZ.LE.20 ! Nuclei for Chlorine through Calcium 
REGI0N3 = IZ.GE. 21 .AND. IZ.LE.92 I Nuclei for Scandium through Uranium 

Initial Rejections: 

REJECTED = NULL. 
& OR . NOT_CONS ERVED . 

& OR . OUT_OF_RANGE . 

& OR.NON_PICKUP 

IF (REJECTED) RETURN 

Non-Spallation, but pick-up reactions: 
IF (PICKUP) THEN 

CALL PXN(REAL(IZ) ,REAL(IA) , REAL ( ( lA- IZ) - (JA-JZ) ) ,EJ,QJ) 

RETURN 
END IF 

Spallation reactions sorted according to Z-number of secondary: 
IF (JZ.LE.4) THEN ! If the secondary nucleus is between H and Be 

CALL YIELDKIZ, lA, JZ, JA, EJ, QJ) 
ELSE 

IF (REGIONl) CALL YIELD2(IZ, lA, JZ, JA, EJ, QJ) 
IF (REGI0N2) CALL YIELD3 (IZ, lA, JZ, JA, EJ, QJ) 
IF (REGIONS) CALL YIELD4(IZ, lA, JZ, JA, EJ, QJ) 
END IF 

Apply energy and/or structure-related correction factors: 
CALL CORRECTIONS (IZ, lA, JZ, JA, EJ, QJ) 




RETURN 
END 



c 
c 

SUBROUTINE CORRECTIONS ( IZ , lA, JZ, JA, EJ, QJ) 

C 

c y/.y.//. ..//,,[[ ,]]]/,[ 

c. . . 

C... This subroutine includes corrections for both the energy and 

C... structure functions. Much of this is outlined in ref [3]. 

C... Latest corrections, however, are outlined in Ref. 15 of CPC 

C. . . write-up! 
C. . . 

C 

c ' • yyyy////////////////. . . [ 

IMPLICIT NONE 
REAL* 4 EJ,QJ 
INTEGER*4 IZ,IA,JZ,JA 
REAL* 4 Q1,Q2,Q3,Q4,EXPF 

REAL*4 QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,AN2J,AA,AE,AC,EC 
COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,AN2J,AA,AE,AC,EC 

C. . . Energy- related corrections to results of YIELDl : 
IF (JZ.LE.4) THEN 
p (IZ.EQ.6 .AND. EJ.GT. 200.0 .AND. EJ.LE. 400.0) 

& QJ = QJ*(1.0 - 0.002* {EJ - 200.0)) 

^ IF (IZ.EQ.6 .AND. EJ.GT. 400.0 .AND. EJ . LE . 1000 . 0) 

'p, t QJ = QJ*0.6 

IF (IZ.EQ.6 .AND. EJ.GT. 1000.0 .AND. EJ . LE . 5000 . 0 ) 
Lr & QJ = QJ*(0.6 + 0.0001* (EJ - 1000.0)) 

s s I 

C. . . structure-related corrections to results of YIELDl: 

(IZ.EQ.6 .AND. IA.EQ.12 .AND. JZ.EQ.4 .AND. JA.EQ. 8) 
= & QJ = QJ*1.8 

H ENDIF 

ru 

bJ C... structure-related corrections to restuls of YIELDl, 3, and 4: 

H= IF (IZ.EQ.7 .AND. IA.EQ.14 .AND. JZ.EQ.6 .AND. JA.EQ. 12) 

^ & QJ = QJ*1.8 

IF (IZ.EQ.7 .AND. IA.EQ.14 .AND. JZ.EQ.6 .AND. JA.EQ. 13) 

& QJ = QJ*0.5 

IF (IZ.EQ.8 .AND. IA.EQ.16 .AND. JZ.EQ.6 .AND. JA.EQ. 12) 

& QJ = QJ*1.8 

IF (IZ.EQ.8 .AND. IA.EQ.16 .AND. JZ.EQ.7 .AND. JA.EQ. 14) 

& QJ = QJ*1.8 

IF {IZ.EQ.8 .AND. IA.EQ.16 .AND. JZ.EQ.7 .AND. JA.EQ. 15) 

& QJ = QJ*1.5 

C 

C. . . 
C 

IF (IZ.EQ. 8 .OR.IZ.EQ.IO) THEN 

IF (IZ*2.EQ.IA.AND. JA-2*JZ.GE.2.AND. JZ.GE.5) QJ=QJ*0 7 

ENDIF 

IF (IZ.GE. 9.AND.IZ.LE.16.AND.2*JZ-JA.EQ.1.AND. JZ.GE.9)QJ=QJ*.7 
IF (IZ.GE.10.AND.IZ.LE.13.AND.IA-IZ*2.NE.2) THEN 

IF(( JZ.EQ.6. AND. JA.EQ. 12) .OR. ( JZ . EQ . 8 . AND . JA . EQ . 16 ) } QJ=QJ*2 
ENDIF 

IF( (IZ.EQ.10.AND.IA.EQ.20) .or. (IZ . EQ. 12 . AND, lA. EQ . 24) ) THEN 

IF (JZ.EQ.7. AND. (JA.EQ. 14. OR. JA.EQ. 15)) QJ=QJ*1 5 

ENDIF 



IF (IZ.GE.lO.^^IZ.LE.ie.AND. JZ.EQ.9 ) QJ=QJ*0.6 
IF ( (IZ.EQ.12.0R.I2.EQ.14.0R.IZ.EQ.16) .AND. (2*IZ.EQ.IA) ) THEN 
IF {IZ-JZ.EQ.2.AND.IA-JA.EQ.4) QJ=QJ*1.6 
IF (IZ-JZ.EQ.l.AND.IA-JA.EQ.l) QJ=QJ*1.6 
ENDIF 

IF ( (IZ.EQ.18.OR.IZ,EQ.20) .AND.2*IZ.EQ.IA) THEN 

IF (IZ-JZ.EQ.1.0R.IZ-JZ.EQ.3) QJ=QJ*0.7 
ENDIF 

IF { I Z . EQ . 2 0 . AND . lA . EQ . 4 0 . AND . ( JZ . EQ . 12 . OR . JZ . EQ . 14 ) ) Q J=Q J* 2 . 4 
IF (IZ.EQ.20.AND. IA.EQ.4 0.AND. ( JZ . EQ . 18 . OR . JZ . EQ . 16 ) )QJ=QJ*1.6 
IF (IZ.GE.24.AND.IZ.LE.28) THEN 

IF ( JZ . GE . 20 . AND . JZ . LE . 23 . and . JA- JZ*2 . GE . 6 ) QJ=QJ*0 . 5 

ENDIF 

IF( (IZ.EQ,26.AND.IA.EQ.56) .OR. ( IZ . EQ . 24 . AND . lA. EQ . 52 ) ) THEN 

IF( (JZ.EQ.20) .OR. (JZ.EQ.18) .OR. (JZ.EQ.16) ) QJ=QJ*1.3 
ENDIF 

IF (IZ.GE. 30.AND. IZ- JZ.GE.6) 
& QJ = QJ* (1.0+0. 9*EXPF(- { (EJ-1230) /ISO) **2) 
& *EXPF(- {ABS(IZ-JZ-12) /5. ) **2) ) 

IF (IZ.EQ.26 .AND. IA.EQ.56 .AND. J2.EQ.23) 
& QJ = QJ*(1.0 - 0.6*EXPF{-({52-JA)/2.6)**2)) 

IF (IZ.EQ.26 .AND. IA.EQ.56 .AND. JZ.EQ.24. AND. JA.EQ.54) 
& QJ = 0.7*QJ 

IF (IZ.EQ.26 .AND. IA.EQ.56 .AND. JZ.EQ.25. AND. JA.GE.54 .AND. 
& JA.LE.55) QJ = QJ*{1.7 - ( JA-54 ) *0 . 45) 

IF (IZ.EQ.26 .AND. IA.EQ.56 .AND. JZ.EQ.26 .AND. JA.EQ.53) 
& QJ = QJ*2.0 

IF (IZ.EQ.26 .AND. IA.EQ.56 .AND. JZ.EQ.17) QJ = QJ*0.9 

C 

IF (JZ.EQ.5) THEN 

CALL YIELDKIZ, lA, JZ, JA, EJ, Ql) 
QJ = SQRT(Q1*QJ) 

IF {IZ.EQ.7 .AND. IA.EQ.14 .AND. JZ.EQ.5 .AND. JA.EQ.IO) 
& QJ = QJ*1.8 

IF (IZ.EQ.6 .AND. IA.EQ.12 .AND. JZ.EQ.5 .AND. JA.EQ.IO) 
& QJ = QJ*1.8 

IF (IZ.EQ.6 .AND. IA.EQ.12 .AND. JZ.EQ.5 .AND. JA.EQ.ll) 
& QJ = QJ*1.5 

ELSE 

IF (IZ. EQ. 20. A2ro. JZ.GE.6) THEN 

CALL YIELD4 (IZ, lA, JZ, JA,EJ,Q4) 

QJ = SQRT(QJ*Q4) 
ENDIF 

IF (IZ.EQ.21 .AND. J2.GE.6) THEN 

CALL YIELD3(IZ, lA, JZ, JA, EJ, Q3) 
QJ = SQRT(QJ*Q3) 
ENDIF 
ENDIF 
RETURN 
END 

C 
C 
C 
C 

C 

C ./.[[[[][[.[[[[./ 

c. , . [ 

C... The next four subroutines are used in the determination of the 
C... various parameters in Table 1 of ref [1]. They are presented in. 
C. . . this fashion to facilitate optimization with the data. 



C. . . YIBLOK - Parameters as in Table lA of ref [1] . 

C... Y2BL0K - Parameters as in Table IB of ref [1]. 

C... Y3BL0K - Parameters as in Table IC of ref [1]. 

C... y4BL0K - Parameters as in Table ID of ref [1]. 

C. . . 

C 

C 

c 
c 

BLOCK DATA YIBLOK 

COMMON /AT/ BA,C2,C3,C4,C5,QC,QL,B,PC,PL,RC,RL,RU,S,SE,C,T,ET 

DIMENSION BA(92), C2(56), C3 (56) , C4(56), C5(56), ET{4) 
DATA BA / 16 * 0.0, 36.0, 38.0, 40.0, 44.0, 
& 45.0, 48.0, 50.0, 52.0, 55.0, 55.7, 58.5, 61.0, 64.0, 67.0, 
& 70.0, 73.0, 75.0, 78.0, 80.0, 82.0, 84.0, 86.0, 89.0, 92.0, 
& 93.0, 96.0, 98.0,100.0, 103.0, 106.0, 108.0, 111.0, 114.0, 118.0, 
&122. 0,125. 0,127. 0,130.0, 133.0, 134.0, 137.0, 139.0, 141.0, 146.0, 
&146.0,149.0, 153.0, 156.0, 159.0, 161.0, 165.0, 166.0, 169.0, 172.0, 
&175. 0,178. 0,181. 0,183.0, 186.0, 188.0, 192.0, 194.0, 197.0, 200.0, 
&204. 0,206. 0,209.0, 0.0, 0.0, 0.0, 0.0, 226.^0, 227.0, 232.0, 
&231. 0,238.0/ 

^ C... Parameters for calculating OMEGA of Equation (1) in ref [1]. 
p DATA C2/ 5*1.0, 0.60, 1.00, 1.00, 1.00, 1.00, 46*1.0/ 

Q DATA C3/ 5*1.0, 1.00, 1.80, 0.70, 3.00, 1.00, 46*1.0/ 

F?: DATA G4/ 6*1.0, 0.95, 1.00, 0.65, 1.30, 1.00, 45*1.0/ 

DATA C5/ 7*1.0, 0.20, 1.00, 0.70, 1.70, 1.00, 44*1.0/ 

§ : 3 

r: C... Parameters for calculating sigma_0 of Equation (1) in ref [1]. 
^ DATA QC/ 13.0/, QL / 13 . 0/ , B / 1 . 15/ 

C... Parameters for calculating P of Equation (1) in ref [1]. 
HJ data PC/ 0.0/, PL / 0.16/ 

rri? 

C... Parameters for calculating R of Equation (1) in ref [1]. 
iO DATA RC/ 1.80/, RL / 10.7/ , RU/ 0.25/ 



C 
C 



Parameters for calculating S of Equation (1) in ref [1] . 

DATA S / 0.54/, SE / 1.4/, C / 0.32/ 

Variable T of Equation (1) in ref [1] . 
DATA T/ 0.003/ 

Parameter eta of Table lA of ref [1] . 

DATA ET / 1.15, 1.15, 0.9, 0.8/ 

END 



BLOCK DATA Y2BLOK 

COMMON /BT/ QM, C5 , C6 , C7 , C8 , C9 , CD, Dl , D2 , D3 , D4 , D5 , D6 , PC, PL, PU, PG, PH, 
& S, SE,C,RC,RL,RU,T,ET 

The variable CJ holds the values for the parameter OMEGA of [1] . 
DIMENSION ET{4), QM(7) 

DIMENSION C5(56), C6 (56) , C7 (56) , C8(56), C9(56), CD{56) 



DIMENSION Dl{^^, D2 {56), D3(56), D4 (56) , D5(^^D6(56) 

DATA C5/ 7*1.0, 0,20, 1.00, 0.70, 1.70, 1.00, 44*1.0/ 

DATA C6/ 9*1.0, 0.60, 46*1.0/ 

DATA C7/12*1.0, 0.39, 1.00, 2.00, 41*1.0/ 

DATA C8/14*1.0, 1.20, 1.00, 1.00, 39*1.0/, C9/l7*l . 0, 1 . 00 , 38*1 . 0/ 

DATA CD/18*1.0, 0.60, 1.00, 0.83, 35*1.0/, Dl/21* 1 . 0 , 1 . 20 , 34 *1 . 0/ 

DATA D2,D3,D4,D5,D6/56*1.0, 56*1.0, 56*1.0, 56*1.0, 56*1.0/ 

Parameters for determining sigmaO in Table IB of ref [1] . 
DATA QM / 27.6, 0.66667, 1.0, 1.0, 0.3, 0.05, 0.5/ 

Parameters for determining P of [1] . 
DATA PC,PL,PU/0.075, 2.60, 0.50/, PG, PH /0.77, 0.66667/ 



Parameters for determining S of [1] . 
DATA S, SE, C/0.502, 1.4, 0.26/ 

Parameters for determining R of [1] . 
DATA RC,RL,RU/1.60, 10.2, 0.26/ 

The variable T in [1] . 
DATA T/ 0.0005/ 

Parameter eta as in Table IB of ref [1] . 
DATA ET / 1.15, 1.15, 0.9, 0.8/ 



END 



BLOCK DATA Y3BL0K 



COMMON /CT/ BA,QT,P0,P1,P2,P3,P4,P5,R0,R1,R2,S0,S1,T,ET 
DIMENSION BA(92), QT(7), ET{4) 



DATA 


BA 


/ 16 * 


0.0, 


36 


.0, 


38 


.0, 


40 


.0, 


44 


.0, 












& 45 


.0, 


48 


.0, 50. 


0, 52. 


0, 


55 


.0, 


55. 


7, 


58 


.5, 


61. 


0, 


64 


.0, 


67 


.0, 


& 70, 


.0, 


73 


.0, 75. 


0, 78. 


0, 


80 


.0, 


82 . 


0, 


84 , 


.0, 


86 . 


0, 


89, 


.0, 


92 


.0, 


& 93, 


.0, 


96 


.0, 98. 


0, 100. 


0, 


103, 


.0, 


106. 


0, 


108 , 


.0, 


111. 


0, 


114 , 


.0, 


118 


.0, 


&122 , 


.0, 


125 


.0,127. 


0, 130. 


0, 


133. 


.0, 


134. 


0, 


137. 


.0, 


139. 


0, 


141. 


.0, 


146 


.0, 


&146 , 


.0, 


149 


.0,153. 


0,156. 


0, 


159. 


.0, 


161. 


0, 


165. 


.0, 


166. 


0, 


169. 


.0, 


172 


.0, 


&175. 


.0, 


178 


.0,181. 


0,183. 


0, 


186, 


.0, 


188. 


0, 


192. 


.0, 


194 . 


0, 


197, 


0, 


200 


.0, 


&204 . 


0, 


206 


.0,209. 


0, 0. 


0, 


0. 


.0, 


0. 


0, 


0. 


.0, 


226. 


0, 


227, 


.0, 


232 


.0, 


&231. 


0, 


238 


.0/ 





























Parameters used in calculating sigmaO in Table IC of ref [1] . 
DATA QT/ 27.6, 0.6667, 1.0, 1.0, 0.3, 0.05, 0.5/ 



Parameters used in calculating parameter P in Table IC of ref [1] . 
DATA P0,P1,P2,P3,P4,P5 /20.0, 0.77, 1,98, 0.92, 0.77, 0.6667/ 

Parameters used in calculating parameter R in Table IC of ref [1] . 
DATA R0,R1,R2 /10.2, 0.26, 1.60/ 

Parameters used in calculating parameter S in Table IC of ref [l] . 
DATA SO, SI /0.502, 0.08/ 



Parameters T in Table IC of ref [1] . 
DATA T /0.0005/ 



Values for eta in Table IC of ref [1] . 



DATA ET /I. 2 0.85/ 



END 

C 
C 

BLOCK DATA Y4BL0K 



COMMON /DT/ BA,SO,S1,T3,RO,R1,R2,R3,PO,P1,P2,P3,EO,E1,C1,C2,C3,C4, 
& D1,D2,T2,ET 

C... BA is an array representing the average atomic number for all stable 
C. . . isotopes of a given element. 
DIMENSION BA(92), ET(4) 

DATA BA / 16 * 0.0, 36.0, 38.0, 40.0, 44.0, 
& 45.0, 48.0, 50.0, 52.0, 55.0, 55.7, 58.5, 61.0, 64.0, 67.0, 
& 70.0, 73.0, 75.0, 78.0, 80.0, 82.0, 84.0, 86.0, 89.0, 92.0,' 
& 93.0, 96.0, 98.0,100.0, 103.0, 106.0, 108.0, 111.0, 114.0, 118.0,' 
&122. 0,125. 0,127. 0,130.0, 133.0, 134.0, 137.0, 139.0, 141.0, 146. o! 
&146. 0,149. 0,153. 0,156.0, 159.0, 161.0, 165.0, 166.0, 169.0, 172. o! 
&175, 0,178. 0,181. 0,183.0, 186.0, 188.0, 192.0, 194.0, 197. o] 200.0,' 
&204. 0,206. 0,209.0, 0.0, 0.0, 0.0, 0.0, 226.0, 227.0, 232 o' 
&231. 0,238./ 

C... Parameters for calculating S, ?????? and R as in Table ID of ref [l] 
DATA S0,Sl,T3/0.482,0.07,3.0E-7/, RO , Rl , R2 , R3 /ll . 8 , 0 . 45 , 1 . 29 , 0 . 15/ 

DATA P0,P1,P2,P3/1.98, 0.92, 20.0, 0.77/, EO, El/20. 3, 1.169/ 

C... Parameters for calculating sigmaO in Table ID of ref [l] and Delta A 
C... in Equation (2) of ref [1]. ~ 
DATA C1,C2,C3,C4/144.0, 0.367, 0.3, 0.7/, Dl , D2/0 . 036 5 , 1.23/ 

C... T in Table ID of ref [i] . 
DATA T2/ 2.8E-4/ 



C... Parameter eta in Table ID of ref [l] , 
DATA ET / 1.25, 0.9, 1.0, 0.85/ 



END 

C 
C 
C 

c 

SUBROUTINE YIELDl {IZ, lA, JZ, JA, EJ, QJ) 
C. 

c 

c. . . 

C... This subroutine is for the case where the incoming nucleus is 
C... at least as large is lithium and the secondary nucleus is 
C... between helium and beryllium, i.e., 

5 .LE. IZ .LE. 16 .AND. 5 .LE. JZ LE IZ 

C... 

C 

c ,/.////.,[ 

C... Get parameters as in Table 11 of ref [l] . 
EXTERNAL YIBLOK 



COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,PJ,PN,GA,ANZJ,AA,AE,AC,EC 
COMMON /QG/ QI,G1,G2,G3,G4 



Commented out lip^«1ark Mattson, April 19, 1996.^^^ 

COMMON /ST/ ST,SS,T 

COMMON /AT/ BA,C2,C3,C4,C5,QC,QL,B,PC,PL,RC,RL,RU,S,SE,C,T,ET 



DIMENSION BA{ 92) , CJ{56,26), C2 (56) , C3{56), C4(56), C5(56), ET(4) 

Parameters for calculating OMEGA of Equation (1) in ref [1] . 
EQUIVALENCE (CJ(1, 2 ) , C2 ) , (CJ ( 1 , 3 ) , C3) , (CJ ( 1 , 4 ) , C4 ) , (CJ ( 1 , 5),C5) 

QR = 0.0 
QE = 0.0 
QF = 0.0 
QH = 0.0 
AE = 0.0 
AC = 0.0 

FE = 1.0 ! Initial value of f(E) of Equation (1) of ref [1], 
FF = 1.0 

FA = 1.0 ! Initial value of f (A) of Equation (2) of ref [1]. 
FZ = 1.0 
PN = 1.0 
GA = 1.0 

REAL*4 values for the integers describing atomic no. and atomic wgt . 
AI = lA 
ZI = 12 
AJ = JA 
ZJ = JZ 

Difference in atomic wgts . 
AA = AI - AJ 

REAL*4 Number of neutrons in secondary nucleus . 
AN = AJ - ZJ 

Ratio of neutrons to protons in secondary nucleus. 
ANZJ = AN/ZJ 

Determination of the nuclear structure function, OMEGA, of Equation (1) 
in ref [1] . 
PJ = CJ(JA,JZ) 

Determination of ratio (N/Z) * as on p. 349 of ref [2]; used in 
calculation of f (A) of equation (1) of ref [1], 

•AM = BA(IZ) 

IF (AM.EQ.O) AM = lA 

CN = 0.3* (AI - AM) /ZI 

Change in the number of neutrons between target and secondary nuclei . 
KN = (lA - IZ) - (JA - JZ) 

Change in the number of protons between target and secondary nuclei, 
including initial proton. 
JP = IZ - JZ + 1 

Integer number of neutrons in secondary nucleus . 
JN = JA - JZ 

Determination of eta of Equation (1) 



MN = JN .AND. 1 



MZ = J2 .AND. f 



PN = 1.15 

IF{MZ.EQ.l .AND. MN.LE.l) PN = 0.9 - 0.1*MN 

IF(MZ.EQ.O .AND. MN.EQ.O) PN = ET(1) 

IF(MZ.EQ.O .AND. MN.EQ.l) PN = ET(2) 

IF(MZ.EQ.l .AND. MN.EQ.O) PN = ET(3) 

IF{MZ.EQ.l .AND. MN.EQ.l) PN = ET(4) 

Determination of cutoff energy, EO (either 1250 MeV or from Equation (" 
of ref [1] . ) . 

EC = 68. 7*AI**0.866 

IF (EC. LT. 1250.0) EC =: 1250.0 

EI = EJ 

IF (EI.GT.EC) EI = EC 

Calculation of correction factor to H(E) in Equation (25) on page 358 
of ref [2] . 
H3 = 1.0 

IF (EI. LT. 80.0) H3 = 1. - EXPF (- (EI/25 .) **4 ) 

If the secondary nucleus is higher than helium or if the change in the 
number of neutrons is greater than 1, it will be handled later. 
IF(JP.GT.2 .OR. KN.GT.l) GO TO 3 

Calculation of correction factor as described on p. 358 of ref [2] ; 
CX .NE. 1 is for light secondary nuclei. 
CX = 1.0 

IF (JZ.EQ.4 .AND. JA.EQ.9) CX = CJ{JA,JZ)/PN 

Calculation of correction factor for light nuclei as described on 

p. 876 of ref [3] . 
IF (AI/ZI.GT.2.0) CT = (ZI - 2.0)/((AI - ZI) - 2.0) 
IF {ZI.GT.5 .OR. CT.GT.1.0 .OR. (AI-ZI) . LE . 2 . 0) CT = 1.0 

IF (JP.GT.l) GO TO 2 ! Case of > 1 proton in secondary nucleus, 
IF (KN.GT.l) GO TO 3 ! Case of > 1 neutron created in reaction. 

Cross section for (p,pn) as shown in Equation (24) of ref [2] on p. 357 
IF (AI.LE.40.0) QN = 24.0*(1.0 + 0.01*AI) 
IF (AI.GT.40.0) QN = 1.02*(AI - 7.0) 
IF (AI.GE.63.0) QN = 57.0 

Calculation of H(E) as in Equation (25) on p. 358 of ref [2] . 
IF (EI.LT.2500. 0) 

& FE = (1.0 + 2. 1*EXP(- (EI/100. 0)**2) + 0 . 4*EXP ( -EI/350 . 0) ) *H3 

Calculation of cross section for (p,pn) reaction. 
QH = QN*CX 
QJ = QH 

IF (EI.LT.EC) QJ = QH*FE 
RETURN 

IF (KN.NE.O) GO TO 3 i Case for no neutrons created in reaction. 
Calculation of cross section for (p,2p) reaction as shown in Equations 
(26) and (27) on p. 358 of ref [2] . 

This is the calculation of H(E) as in Eq. (27) on p. 358 of ref [2] . 

IF (EJ.LT. 2500.0) FE = (1.0 - EXPF { - (EJ/230 . ) **2 ) + 
& 2.2*EXPF{-EJ/75.0) + 0 . 33*EXPF ( - ( (EJ-900 . 0) /500 . 0) **2 ) ) *H3 



21.0 is the value of sigma(EO) as shown in Eq. (26) of ref [2]. 



QH = 21.0*CX*C 
QJ = QH*FE 
RETURN 



If the atomic number is greater than 29, then the cross-section needs 
to be modified by f (A) and f (E) as outlined in Table 1 on page 340 of 
ref [2] (FE and FA were previously set equal to 1) . 
IF (IZ.LT.29) GO TO 5 

Calculation of f (E) of Equation (1) of ref [1] . 
IF (JZ.NE. 4) FE = (EI/EC) ** (0.4*ZJ) ! Helium and Lithium nuclei 
IF (JZ.EQ. 4) FE = (EI/EC)**1.8 ! Beryllium nuclei 

Calculation of f (A) in Equation (1) or ref [2]; Eq. (10) on p. 351 of 
ref [2] . 

FA = EXPF(0.01* (AI - 56.0)*{AN/ZJ - CN - 0.45)) 
IF (FA.LE.1.0) FA = 1. 



EI = EC 
ZI = 29.0 
AI = 63.0 

Calculation of enhancement factor xi of Equation (1) of ref [1] ; 
see Table 2 of ref [3] . 
AT = lA 

IF (IA.GE.104) AT = 104 
IF (IA.GE.64) GO TO 7 
IF (IA.GT.34) GO TO 6 

Situation described in Table 3 of ref [1] . 
IF (IA.GE.14 .AND. JA.EQ.6 .AND. JZ.EQ. 2) FZ = 1.0 + 0.1*(IA - 14) 
GO TO 8 

Enhancement factor xi when target nucleus has 34 .LE. lA .LE. 63 
IF {JA.EQ.6 .AND. JZ.EQ. 2) FZ = 3.0*(1.0 + 0.02*(IA - 34)) 
IF (JA.EQ.6 .AND. JZ.EQ. 3) FZ = 1.0 + 0.02*(IA - 34) 
IF (JA.EQ.7 .AND. JZ . LE . 4 ) FZ = 1.0 + 0.01*(IA - 34) 
GO TO 8 

Enhancement factor xi when target nucleus has 64 .LE. lA .LE. 104 



IF 


(JA. 


EQ. 


,6 


.AND. 


JZ 


.EQ. 


.2) 


FZ = 


4 


.8 


+ 


0. 


.0450* (AT - 


- 64 


.0) 


IF 


(JA. 


EQ. 


,6 


.AND. 


JZ 


.EQ. 


,3) 


FZ = 


1 


.6 


+ 


0. 


.0150* (AT - 


- 64, 


.0) 


IF 


(JA. 


EQ. 


,7 


.AND. 


JZ 


.EQ. 


,3) 


FZ = 


1 


.3 


+ 


0. 


.0150* (AT - 


■ 64, 


.0) 


IF 


(JA, 


EQ. 


,7 


.AND. 


JZ 


.EQ. 


,4) 


FZ = 


1 


.3 


+ 


0. 


.0105* (AT - 


- 64, 


.0) 


IF 


(JA.EQ. 


,8 


.AND. 


JZ 


.EQ. 


.3) 


FZ = 


1 


.0 


+ 


0. 


.0225* (AT - 


■ 64, 


.0) 


IF 


(JA. 


EQ. 


,9 


.AND. 


JZ 


.EQ, 


.3) 


FZ = 


1 


.0 


+ 


0. 


.0125* (AT - 


■ 64, 


.0) 


IF 


(JA. 


EQ. 


,9 


.AND. 


JZ 


.EQ. 


,4) 


FZ = 


1 


.0 


+ 


0. 


.0100* (AT - 


' 64, 


.0) 


IF 


(JA. 


GE. 


,10 


.AND. 


JZ 


.LE. 


5) 


FZ = 


1 


.0 


+ 


0. 


.0050* (AT - 


■ 64, 


.0) 



DA = AI - AJ ! Change in atomic weights of target and secondary nucle 
AA = DA 

Calculation of delta A_c as in Equation (2) of ref [1] . 
AE = 31.5 + 0.052*(AI - 36 . 0) * (ALOG (EI) - 3.17) 

Determination of delta A in Equation (1) of ref [1] . 
IF (AA.GT.AE) DA = AE 



Determination of sigmaO in Equation (1) of ref [1] 



Ql = QC 

IF (EI. LT. 1250.0) Ql = QL*EXPF (B* ( 1 . 0 - 0.0008*EI)) 



Determination of P in Equation (1) of ref [1] . 
PE = PC 

IF (EI .LT. 1250. 0) PE = PL* (1 . - 0.0008*EI) 

Determination of R in Equation (1) of ref [1] . 
RE = RC 

IF (EI. LT. 1250.0) RE = RL/EI**RU 

IF{I2.GT.20 .AND. EI . LT . 1250 . 0 ) RE = 1.8 

Correction factor for sigmaO (f3 in Table lA of ref [1]) . 

IF(EI.LT. 1250.0 .AND. IZ.GE.21) 
& Ql = Ql*2 .0*EXPF(- ( (EI - 650 . 0) /72 0 . 0) **2 ) 

Determination of S in Equation (1) of ref [1] . 
IF (AI/ZI.GE.2.0) SS = S - C* (AI/ZI - 2.0)**SE 
IF (AI/ZI. LT. 2.0) SS = S + C*(2.0 - AI/ZI) **SE ! See ref [3] 

Determination of portion of exponent in Equation (1) of ref [1] 
within absolute value symbol . 

ST = (ZJ - (SS - T*AJ)*AJ) 

ZA = (ZJ - (SS - T*AJ)*AJ)**2 

Calculation of cross section. 
QR = Q1*EXPF(-PE*DA - RE*ZA) *FA*FZ*CJ ( JA, JZ) 
QH = QC*EXPF{-RC*ZA) *FA*FZ*CJ(JA, JZ) 
QE = QH*FE 

IF (IZ.LT.29) QJ = QR 
IF {IZ.GE.29) QJ = QE 

Enhancement factor for (p,3p) reactions, as shown on p. 876 of ref [3] 
IF (JP.EQ.3 .AND. KN.EQ.O) QJ = 1.5*QR 

FOLLOWING REVISIONS ARE ADDED 12/27/78 
From ref [3] , the cross section QJ is to be modified by a correction 
factor. 

IF (IZ.LE.20) RETURN 

Ql = QJ 

Determination of E' as shown below Equation (3) of ref [3] . 
EX = 68. 7*56. 0**0. 866*EJ/EC 

AC = 31.5 + 0.045*(AI - 36 . 0 ) * (ALOG (AI ) + 1.23) 

Equation (3) of ref [3] . 

Gl = 1.0 - 0.6*(1.0 - EXPF(- (EJ/1000.0)**2) )*EXPF(- (EJ/2000.0)**2) 
& + 0.2*(1.0 - EXPF(- (EJ/3000. 0) **2) ) 

GX = 1.0 - 0.6*(1.0 - EXPF(- (EX/1000.0) **2) ) *EXPF(- (EX/2000. 0)**2) 
& + 0.2*(1.0 - EXPF(- (EX/3000.0) **2) ) 

Calculation of f2 in Equation (9) of ref [3] . 

G2 = 1.0 - 0.4*(1.0 - EXPF(- (EX/2000.0) **2) ) * 
& EXPF(- ( (EX-1800.0) /1800.0) **2) + 

& 0.17*(1.0 - EXPF{- {EX/2000.0) **2) ) 

Determination of fl for the conditions described in Eq. (4) of ref [3] 
IF (EJ.GT.2500. ) Gl = GX 

IF (EJ.GT.EC .AND. EJ. LT . 2500 . 0) Gl = SQRT(G1*GX) 



L^^^ cross 



Modification of 
IF (I2.GE.21 .AND. IZ.LE.28) QJ = QR*G1 
IF (IZ.GT.28 .AND, AA.GT.AC) QJ = QE*G2 



RETURN 
END 

C 

c 
c 
c 

SUBROUTINE YIELD2 (12, lA, JZ, JA, EJ, QJ) 

C 

c * 

c . . . 

C,,. This subroutine is for the case where the incoming nucleus is ... 

C. . . for elements between boron and sulphur and the secondary nucleus... 

C... is between boron and the incoming nucleus, i.e., 

C. . . 5 .LE. IZ .LE. 16 .AND. 5 .LE. JZ .LE IZ 

C. . . 

C ' " 

C 

C.,. Get parameters is described in Table IB of ref [1] . 
EXTERNAL y2BL0K 



COMMON /BT/ QM, C5 , C6 , C7 , C8 , C9 , CD, Dl , D2 , D3 , D4 , D5 , D6 , PC , PL, PU, PG, PH, 
& S, SE,C,RC,RL,RU, T,ET 

COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,PJ,PN,GA,ANZJ,AA,AE,AC,EC 
C. . . Commented out by Mark Mattson, April 19, 1996. 
C COMMON /ST/ ST,SS,T, 



C. . . The variable CJ holds the values for the parameter OMEGA of [1] . 
DIMENSION CJ(56,26), ET(4), QM{7) 

DIMENSION C5(56), C6 (56), C7 (56) , C8(56), C9(56), CD{56) 
DIMENSION Dl{56), D2(56), D3 (56) , D4(56), D5(56), D6 (56) 
C EQUIVALENCE (CJ(1, 5) , C5) , (CJ ( 1 , 6 ) , C6 ) , (CJ (1 , 7 ) , C7 ) , (CJ (1 , 8),C8) 

C EQUIVALENCE (CJ(1, 9) ,C9) , (CJ(1,10) , CD) , (CJ(1,11) ,D1) , (CJ(1,12) ,D2) 

C EQUIVALENCE (CJ (1,13) ,D3) , (CJ(1,14) ,D4) , {CJ(1,15) ,D5) , (CJ(1,16) ,D6) 



DO 1=1,56 




CJ(I,5) 


= C5(I) 


CJ(I,6) 


= C6(I) 


CJ(I,7) 


= C7(I) 


CJ(I,8) 


= C8(I) 


CJ{I,9) 


= C9(I) 


CJ(I,10) 


= CD(I) 


CJd.ll) 


= Did) 


CJ{I,12) 


= D2(I) 


CJ(I,13) 


= D3(I) 


CJ(I, 14) 


= D4(I) 


CJ(I,15) 


= DSd) 


CJ(I,16) 


= DSd) 



ENDDO 



QR = 0.0 
QE = 0.0 
QF = 0.0 
QH = 0.0 
AE = 0.0 
AC = 0.0 



PE = 1.0 



FF = 


1.0 


FA = 


1.0 


FZ = 


1.0 


GA = 


1.0 


AI = 


lA 


ZI = 


IZ 


AJ = 


JA 


ZJ = 


JZ 


AA = 


AI - AJ 


AN = 


AJ - ZJ 


ANZJ 


= AN/ZJ 



Real number for the atomic weight of the incoming nucleus 
" " " " " number " " " " 

" " " " weight " " secondary " 

" " " " " number " " " " 

Difference in atomic weights of nuclei 
Number of neutrons in the secondary nucleus 
Ratio of neutrons to protons in secondary nucleus 



Determination of OMEGA in ref [1] 
PJ = CJ(JA,JZ) 



JN = JA - JZ • Integer for number of neutrons in secondary nucleus 
MN = JN.AND.l I Is the # of neutrons even or odd? 
MZ = JZ.AND.l ! Is the # of protons even or odd? 
CX = 1. 



The variable PN is eta as in ref [1] . 
PN = 1.15 

IF(MZ.EQ.l .AND. MN.LE.l) PN = 0.9 - 0.1*MN 

IF(MZ.EQ.0 .AND. MN .EQ.O) PN = ET(1) 

IF(MZ.EQ.O .AND. MN .EQ.l) PN = ET{2) 

IF(MZ.EQ,1 .AND. MN .EQ.O) PN = ET(3) 

IF(MZ.EQ.l .AND. MN .EQ.l) PN = ET{4) 

Determination of EO ("critical energy") as in ref [1] ; 
1250 MeV is the lower bound. 

EC = 68.7*AI**.866 

IF (EC. LT. 1250.0) EC = 1250.0 



EI = EJ 

IF (EI.GT.EC) EI = EC 

H3 =: 1.0 

IF (EI. LT. 80.0) H3 = 1.0 - EXPF (- (EI/25 .) **4) 



KN = (lA - IZ) - (JA - JZ) ! Difference in number of n's 

JP = IZ - JZ + 1 • " " " " p's (inc. 1st) 

IF{(JZ.EQ.7 .AND. JA.EQ.13) .OR. (JZ.EQ.IO .AND. JA.EQ.19)) 
& CX = CJ(JA,JZ) 

Correction factor as described on p. 876 of ref [3] . 
CT = (ZI - 2.0)/((AI - ZI) - 2.0) 
IF {ZI.GT.5.0 .OR. CT.GT.1.0) CT = 1.0 

IF (JP.GT.l) GO TO 2 
IF (KN.NE.l) GO TO 3 

Factors for (p, pn) reactions. 

Calculation of H(E) as in Eq. (25) on p. 358 of ref [2], 

IF (EI. LT. 2500.0) 

& FE = (1.0 + 2. 1*EXPF(- (EI/100.0) **2) + 0 . 4 *EXPF ( -EI/350 . 0) ) *H3 

Equation (24) on p. 357 of ref [2] . 
QH = 24.0* (1.0 + 0.01*AI)*CX 



QJ = QH 
IF (EI.LT.EC) QJ = QH*FE 
GO TO 10 



2 IF(JP.GT.2 .OR. KN.NE.O) GO TO 3 
C. . . Factors for (p, 2p) reactions. 

C... Calculation of H(E) as in Eq. (21) on p. 358 of ref [2]. 
IF (EJ.LT. 2500.0) 
& FE = (1.0 - EXPF(- (EJ/230. 0) **2) + 2 . 2*EXPF ( -EJ/75 . 0) 

& + 0.33*EXPF(- ( (EJ-900.0) /500.0) **2) )*H3 

C. . . Eq. (26) on p. 358 of ref [2] multiplied by correction factors. 
QH = 21.0*CX*CT 
QJ = QH*FE 
GO TO 10 



C, . . Determination of a portion of sigmaO as in ref [1] . 
3 Fl = QM(4) - QM{5)*ALOG{AI*QM(6) ) 

C... Determination of the parameter P of [1], 
PE = PC 

IF (EC, GT. 1250.0) PE = PG/AI**PH 
IF (EI.LT.EC) PE = PL/EI**PU 

Determination of the parameter R of [1] . 
RE = RC 

IF (EI. LT. 1250.0) RE = RL/EI**RU 



fy C... Determination of the parameter S of [1]. 

p IF (AI/ZI.GE.2.0) SS = S - C* (AI/ZI - 2.0)**SE 

hi IF (AI/ZI. LT. 2.0) SS = S + C* (2 . 0 - AI/ZI)**SE 

C. . . Determination of the value in the exponential in Equation (1) in ref [1] . 
ST = (ZJ - (SS - T*AJ)*AJ) 
f{i ZA = (ZJ - (SS - T*AJ)*AJ)**2 

ill 

C... Determination of sigmaO as in ref [1]. 

Ql = QM(1) * (AI**QM(2) - QM ( 3 ) ) *F1 *PE*RE**QM ( 7 ) / ( 1 . 0 -EXPF ( -PE*AI ) ) 
QC = QM(1) * (AI**QM(2) - QM ( 3 ) ) *F1*PC*RC**QM ( 7 ) / ( 1 . 0 -EXPF ( -PC*AI ) ) - 

C. . . Determination of the cross section. 

QR = Q1*EXPF(-PE* (AI - AJ) ) *EXPF ( -RE*ZA) *CJ ( JA, JZ ) *PN 
QJ = QR 

QH = QC*EXPF(-PC* (AI - AJ) ) *EXPF ( -RC*ZA) *CJ ( JA, JZ) *PN 
IF(JP.LT.3 .OR. KN.NE.O) GO TO 10 



QJ = QR*AMIN1(.0022*AJ*AJ,1.) 
IF (JP.NE.4) GO TO 10 
IF {QJ.GT.0.5) QJ = 0.5 



C. . . Determination of the enhancement factor, xi, as in ref [1] . 

10 IF {IZ,GE.14 .AND. EI. GE. 500.0) QJ=QJ*(1.0 + 0.12*(IZ - 13)) 

IF {IZ.GE.14 .AND. EI. GE. 200.0 .AND. EI, LT. 500.0) 

& QJ = QJ*(1.0 + 0.12* (IZ-13) *EXP(- ( (EI-500.0) /350.0) **2) ) 

IF (JP.EQ.2 .AND. KN.EQ.l .AND. IZ.GE.12) QJ = QJ*1 . 7 

IF ( (AJ/ZJ) .GT.1.8 .OR. IZ.GT.IO) RETURN 

IF (JP.NE.l .OR. KN.NE.2) QJ = QJ*0.3 

IF (JP.EQ.l ,AND. KN.EQ.2) QJ = QJ*0.5 



RETURN 
END 

C 
C 
C 
C 

SUBROUTINE YIELD3(IZ, lA, JZ, JA, EJ, QJ) 

C 

C /.,//////.][].]].[,][..[] 

c . . . * ' * 

C... This subroutine is for the case where the incoming nucleus is 
C... for elements between chlorine and calcium and the secondary 
C. . . nucleus is between boron and the incoming nucleus, i.e. , 
C... 17 .LE. IZ .LE. 20 .AND. 5 . LE . JZ . LE . IZ 

C. . . 

C [ ' 

c 

C... Get parameters as in Table IC of ref [1]. 
EXTERNAL Y3BL0K 

COMMON /CT/ BA,QT,P0,P1,P2,P3,P4,P5,R0,R1,R2,S0,S1,T,ET 
COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,ANZJ,AA,AE,AC,EC 
C... Commented out by Mark Mattson, April 19, 1996. 
C COMMON /ST/ ST,S,T 

DIMENSION BA(92), QT{7), ET{4) 

REAL*4 versions of the atomic weights and numbers of the target and 
secondary nucleus . 
AI = lA 
ZI = IZ 
AJ = JA 
ZJ = JZ 

AM = BAdZ) 

IF (AM.EQ.0.0) AM = lA 

Calculation of EO as in Equation (3) of ref [1] . 
EC = 68.7*AI**0.866 
IF (EC.LT. 1250. 0) EC = 1250.0 
EI = EJ 

IF (EI.GT.EC) EI = EC 
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0 
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AI 





C... Calculation of last portion of H(E) in Equation (25) of ref [2]. 
H3 = 1.0 - EXPF{- (AMIN1(EI,80.0) /25.0) **4) 




Calculation of H4 in Equation (29d) of ref [2] . 
H4 = AMINl(AMAXl((400.0/EI-2.2) ,1.0) ,2.0) 



Number of neutrons in secondary nucleus and ratio of neutrons to protons . 
AN = AJ - ZJ 
ANZJ = AN/ZJ 



Calculation of eta as in Table IC of ref [1] . 
JN = JA - JZ 
MN = JN.AND.l 
MZ = JZ.AND.l 
PN = 1.0 

IF (MN+MZ.EQ.2) PN = 0.85 
IF (MN+MZ.EQ.O) PN = 1.25 
IF (MN-MZ.EQ.l) PN = 0.90 
IF(MZ.EQ.O .AND. MN.EQ.O) PN = ET(1) 
IF(MZ.EQ.O .AND, MN.EQ.l) PN = ET(2) 
IF{MZ.EQ.l .AND. MN.EQ.O) PN = ET(3) 
IF{MZ.EQ.l .AND. MN.EQ.l) PN = ET(4) 

Total change in number of protons . 
JP = IZ - JZ + 1 

Total change in number of neutrons . 
KN ^ lA - IZ - JN 

IF(JP.GT.2 .OR. KN.GT.3 .OR. IA.LT.35) GO TO 14 
IF (JP.EQ.2) GO TO 2 

Case for where the change in the number of protons is 1, there are no 
more than two additional neutrons and the target nucleus has an atomic 
weight greater than 35.. 

Calculation of H{E) as in Equation (25) of ref [2] . 
IF (EI. LT. 2500.0) 

& FE =(1.0 + 2.1/EXPF( (EI/IOO.O) **2) + 0 . 4*EXPF ( -El/3 50 . 0 ) ) *H3 



Calculation of cross section if the weight of the target nucleus is 
less than or equal to 40, as in Equation (24) of ref [2] . 

QH = 24.0*(1.0 + 0.01*AI) 

QJ = QH 

Determination of variable d as described below Equation (23) in ref [2] . 
DX = 3.0 

IF (KN.GT.l) DX = 15.0 



IF (EI.LT.EC) QJ = QH*FE 

Temporarily finished for (p,pn) reactions. 
IF (KN.EQ.l) GO TO 5 

(p,pxn) where x .GE. 2. (p. 359 of ref [2]) 
XN = KN 
XA = 1.17 

IF (IZ.LE.30) XA=1.6 



Calculation of cross section as in Equation (28) of ref [2] . 
QH = QH*EXPF(1.0 - XN** (XA - 0.0048*AI)) 
QJ = QH 

IF (EI.GE.EC) GO TO 5 



# • 

C... Temporarily finished with (p,pxn) 
GO TO 4 

C. . . (p,2pxn) reactions. 

C... Calculation of f{e) as in Equation (27) of ref [2]. 
2 IF (EJ.LT. 2500.0) 

& FE = (1.0 - EXPF(- (EJ/230.0)**2) + 2 . 2/EXPF {EJ/75 . 0) 

& + 0.33/EXPF( ( (EJ-900.0) /500.0) **2) ) *H3 



C... Calculation of cross section as in Equation (26) of ref [2], 
QH = 21.0 
QJ = QH 
QJ = QH * FE 



C... Determination of variable d as described below Equation (23) of ref [2]. 
IF (KN.EQ.O) DX = -3.0 
IF (KN.EQ.l) DX = -1.0 

C... Temporarily finished with (p,2p) reactions. 
IF (KN.EQ.O) GO TO 5 

C... Temporarily finished with (p,2pxn) where n > 2. 
IF (KN.GT.2) GO TO 14 

C... Cross section for (p,2pxn}, x .GE. 1 as in Equation (31) of ref [2]. 
QH = 17.0 
QJ = QH 

IF (EI.GE.EC) GO TO 5 
C... Calculation in change in atomic weights. 
4 KA lA - JA 

IF (KA.GE.8) GO TO 5 



C. 
C. 



Calculation of (1 + HI) *H3*H4 as almost in Equation (29) of ref [2]. 

FE = (1.0 + 1.9/EXP( (AA/7.9) **2 + (EI/420 . 0) * *1 . 4 )) *H3*H4 
QJ = QH*FE 



C... Calculation of Y(IA,IZ) as in Equation (22) in ref [2]. 
5 DD = DX*(AI - AM)/ZI 

YA = EXPF(DD) 

IF (DD.GT.O) YA = 2.0 - 1 . O/YA 

IF (IA.IiT.35 .OR. IA.GT.209) YA = 1.0 

IF (IA.LT.70 .AND. JP.EQ.3) YA = 1.0 

C. . . Calculation of cross section. 
QH = YA*QH 
QJ = YA*QJ 
RETURN 

C... Calculations for when the change in the number of protons is greater 
C... than 2, the change in the number of neutrons is greater than 3 or the 
C... atomic weight of the target nucleus is less than 35. 
C. . . Calculation of change in atomic weights. 
14 DA = AI - AJ 

C... Determination of OMEGA for what in this region is a special case (see 
C. . . Table 2 of ref [1] ) . 

IF(JZ.EQ.7 .AND. JA.EQ.13) CJ = 0.39 



Calculation of portion of sigmaO as in Table IC of ref [1] . 
Fl = QT(4) - QT(5) *AUX3(AI*QT{6) ) 

Calculation of f2' as in Equation (6) of ref [1] . 
IF (EI. GE. 600.0) F2 = 1.0 

IF (EI. LT. 600.0) F2 = EXPF (0.90 - 0.0015*EI) 

IF (EI.GE.EC) GO TO 15 
Determination of P in Table IC in ref [1] for low energy. 
PE = P0/EI**P1 
IF (EI.LT.EC) GO TO 16 

Determination of f2' and P in Table IC of ref [l] for high energy 
F2 = 1.00 
PE = P2/AI**P3 

Determination of R in Table IC of ref [1] . 
IF (EI. LT. 1250.0) RE = R0/EI**R1 
IF (EI. GE. 1250.0) RE = R2 

Calculation of sigmaO in Table IC of ref [1] . 

Ql = QT(1) * {AI**QT(2) - QT (3 ) ) *F1*F2*PE*RE**QT { 7 ) / 
& (1.0 - EXPF(-PE*AI) ) 

Calculation of S in Table IC of ref [1] . 
S = SO - S1*ABS(AI/ZI - 2.0) 

Determination of value in second exponent of Equation (1) of ref 
ST = (ZJ - (S - 0.0005*AJ) *AJ) 
ZA = ABS(ZJ - is - 0.0005*AJ) *AJ) **2 

Calculation of cross section as in Equation (1) of ref [1] . 
QJ = Q1*EXPF (-PE*DA-RE*ZA) 
QR = QJ*PX^*CJ 
QJ = QR 

Consideration of high energy case. 
Calculation of P in Table IC of ref [1] . 
PH = P4/AI**P5 

Determination of R in Table . IC of ref [1]. 
RH = R2 



Calculation of sigmaO in Table IC of ref [1] . 

QC = QT(1) * (AI**QT(2) - QT (3 ) ) *F1*PH*RH**QT (7) / 
& (1.0 - EXPF(-PH*AI) ) 

Calculation of cross section as in Equation (1) of ref [1] . 
QH = QC*EXPF{-PH*DA - RH*ZA) *PN*CJ 
IF(JP.NE.3 .OR. KN.GT.O .OR. IA.LT.35) GO TO 20 

Determination of correction factors in (p,3p) reactions. 
FF = 1.0 
FE = 1.0 
QJ = QH 



IF (IZ.LT.14 .OR. IZ.GT.19 .OR. EI. LT. 200.0) RETURN 



C. . . Correction facto^xi. 
C. . . 

IF (EI. GT. 500.0) QJ = QJ*(1,0 + 0 . 12* (IZ-13 ) ) 
IF (EI. LE. 500.0) QJ = QJ*(1.0 + 0 . 12* ( 12- 13 ) * 
& EXP(- ( (EI- 500.0) /350.0) **2) ) 

RETURN 
END 

C 
C 
C 
C 

SUBROUTINE YIELD4 (IZ, lA, JZ, JA, EJ, QJ) 1 see notes at end 

C ' 

C 

c . . . 

C.,. This subroutine is for the case where the incoming nucleus is 

C . . . for elements between scandium and uranium and the secondary 

C... nucleus is between boron and the incoming nucleus, i.e., 

C... 21 .LE. 12 .LE. 92 .AND. 5 . LE . JZ . LE . IZ 

C . . . ' " 

C " ' 

C 

C... Get parameters as in Table ID of ref [1] . 
^ EXTERNAL Y4BL0K 

£? 

g COMMON /DT/ BA, SO , SI , T3 , RO , Rl , R2 , R3 , PO , PI , P2 , P3 , EO , El , CI , C2 , C3 , C4 , 

& Dl , D2 , T2 , ET 

COMMON /FS/ QR,QE,QF,QH,FE,FF,FA,FZ,CJ,PN,GA,ANZJ,AA,AE,AC,EC 
f1 COMMON /Q4/ CO, Fl, F2 , F3 , PE, DA, RJ, ZA, PH, YA, Ql, QM, HM 

2 COMMON /QG/ QI, Gl , G2 , G3 , G4 

C... Commented out by Mark Mattson, April 19, 1996. 
C COMMON /ST/ ST,S,T2 

C... BA is an array representing the average atomic number for all stable 
C... isotopes of a given element. 
H DIMENSION BA(92), ET(4) 

Kl C... REAL*4 versions of atomic weights and numbers of nuclei. 
AI = lA 
ZI = IZ 
AJ = JA 
ZJ = JZ 



AM = BA(IZ) + lA* (300/ (INT(BA(IZ) ) + 300)) 
KM = 0 



FP = 1. 
QJ = 0.0 
QR = 0.0 
QE = 0.0 
QF = 0.0 
QM = 0.0 
HM = 0.0 
QH = 0.0 
AC = 0.0 
AE = 0.0 
DM = 0.0 
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This subroutine doesn't consider reactions where the secondary nucleus 
has more mass, protons or neutrons than the target nucleus. 
IFdA.LE.JA .OR. IZ.LT.JZ .OR. { lA- JA) . LT . ( 12- JZ) ) RETURN 

AA = AI - AJ 

DA = AA 

AN = AJ - ZJ 

ANZJ = AN/ZJ 

ANZI = AI/ZI - 1.0 

JN = JA - JZ I Number of neutrons in product nucleus 

JP = IZ - JZ + 1 ! Change in number of protons 

CN = 0.3* (AI - AM) /2I 

KN=(IA-IZ)-JN I Change in number of protons 
XN = KN 



Calculation of eta in Table ID of ref [l] . 
MZ = JZ.AND.l 
MN = JN.AND.l 

IF ( (MN+MZ) .EQ.2) PN = 0.85 
IF { (MN+MZ) .EQ.O) PN = 1.25 
IF { (MN-MZ) .EQ.l) PN = 0.90 
IF(MZ.EQ.O .AND. MN.EQ.O) PN = ET(1) 
IF(MZ.EQ.O .AND. MN.EQ.l) PN = ET(2) 
IF(MZ.EQ.l .AND. MN.EQ.O) PN = ET(3) 
IF(MZ.EQ.l .AND. MN.EQ.l) PN = ET(4) 



PN = PN + (l.-PN)*(l.-EXPF(-((IA-100)/35.)**2)) 

Calculation of DELTA A_c as in Equation (2) of ref [1] . 
AC = 31.5 + 0.045* (AI - 36 . 0 ) * (ALOG (AI ) + 1.23) 

EI = EJ 

EC = E0*AI**E1 

IF (EC. GT. 4000.0) EC = 4000.0 
IF (EC. LT. 1250.0) EC = 1250.0 
IF (EI.GT.EC) EI = EC 



Determination of maximum value for energy dependence of fission 
section as described on p. 347-8 of ref [2] . 
FMAX = 1800. 0/EI 

IF (IZ.GE.84) FMAX = (1800 . 0/EI) * * ( 6 . 56 - 0.067*ZI) 
IF (FMAX. GT. 4.0) FMAX = 4.0 
IF (EI. GT. 1800.0) FMAX = 1.0 



Determination of OMEGA for certain situations. 
IF (IZ.LE.28 .AND. JZ.EQ.20 .AND. JA.EQ.19) CJ = 0.6 
IF (J2.EQ.7 .AND. JA.EQ.13) CJ = 0.39 





C... Determination of parameter P of Table ID of ref (1] for different 
C. . . energies . 

P500 = P2/(500.0**P3) 

PIOOO = P2/(1000.0**P3) 

P3000 = P2/(3000.0**P3) 

IF (JP.GE.6 .OR. IA.LT.35) GO TO 100 

C. . . 

IF (JP. GE. 4. AND. JP.LE.5. AND. KN.GE.KM.AND.EJ.lt. EC) GO TO 100 
C PERIPHERAL 

C... Calculation of H3 as in Equation (29c) of ref [2] . 
H3 = 1.0 - EXPF(- (EI/{15.0 + 10 . 0*AA) ) * *4 ) 

C... Determination of H4 as in Equation (29d) of ref [2] 
H4 = 400.0/EI - 2.2 
IF {H4.LT.1.0) H4 = 1.0 
IF (H4.GT.2.0) H4 = 2.0 

C... Calculation of H{E) as in Equation (29) of ref [2]. 

HE = (1.0 + 1.9*EXPF(- (DA/7.9)**2 - . {EI/420 . 0) **1 . 4 ) 
& - (1.0 - EXPF(-{DA/12.0)**8))*EXPF(-(EI/420.0)**3))*H3*H4 

^ EC = 2500.0 

S; (JP.GE.3 .AND. JP.LE.5) GO TO 3 

^ IF (JP.EQ.2) GO TO 2 

O 

C... For (p,pn) reactions. 
U C... Calculation of H{E) as in Equation (25) of ref [2] 
W 1 IF (EI. LT. 2500.0) 

M: & FE = (1.0 + 2. 1*EXPF(- (EI/100. 0)**2) + 0 . 4 *EXPF ( -EI/3 50 . 0) ) *H3 

IF (KN.GT.l) FE = HE 

ry C... Calculation of x_max as in Equation (30) of ref [2] 

KM = AI/20.0 + 1.5*(ABS{238.0 - AI) /167 . 0 ) **2 . 5 +08 
IF (IA.LE.70) KM = 3.0 + Al/66.0 

IF (KN.GT.KM) GO TO 100 

C... Calculation of cross section for (p,pn) as in Equation (24) of ref [2] 
IF {IA.LE.40) QA = 24.0*{1.0 + 0.01*AI) ^ ^ or rer 12J . 

QH = QA 

IF {IA.GT.40) QA = 1.02*{AI - 7.0) 
QH = QA 

IF (IA.GE.63) QA = 57.0 
QH = QA 

C... Determination of exponent of x in Equation (28) of ref [2] (see also 
C... p. 876 of ref [3]). 
XA = 1.17 

IF (IZ.LE.30) XA = 1.5 

C... Calculation of cross section for (p,pxn) as in Equation (28) of ref [2] 
IF (KN.NE.l) QH = QA*EXPF(1.0 - XN*MXA - 0.0048*AI)) 

C... Determination of d as described below Equation (23) of ref f21 
IF (KN.EQ.l) DX = 3.0 ^' 
IF (KN.GT.l) DX = 15.0 



c. . . 

QH = QH*(1. + 0.15*(IZ/80.)**2) 

GO TO 6 

Calculation of H(E) as in Equation (27) of ref [2]. 

FE = (1,0 - EXPF(- (EJ/230.0) **2) + 2 . 2*EXPF ( -EJ/75 . 0 ) 

& + 0.33*EXPF{- ( (EJ-900.0) /500.0) **2) ) *H3 

IF (KN.GT.O) FE = HE 

C... Determination of x_max as in Equation (32) of ref [2]. 
KM = 10.0*(1.0 - EXPF(-((AI-39.0)/54.5)**2)) 
IF (KM.LT.2) KM = 2 

IF (KN.GT.KM) GO TO 100 

C... Calculation of cross section as in Equation (31) of ref [2], 
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^ C... Determination of d as described below Equation (23) of ref [2] . 
2 IF (KN.EQ. 0) DX = -3.0 

IF (KN.EQ. 1) DX = -1.0 

GO TO 6 

^ C... Calculation of H*(E) as below Equation (34a) in ref [2] . 

= C. . . 

H 3 F^T = AMINl ( (EI/4200. )** (0.72 - 0. 1S*XN) *H3 , 1 . 0) 

ry IF (IA.LE.70) FE = 1.0 - EXPF ( - (El/3 5 . 0 ) **4 ) 

Ly IF (IA.GT.70 .AND. KN.LE.4) FE = FN 

M IF (IA.GT.70 .AND. KN.GT. 4) FE = H3 

SJ C... Calculation of H(E) as in Equation (34a) of ref [2]. 
IF (EI. LT. 200.0) FE = FE*EI/200.0 

C... Calculation of x_max as in Equation (35) of ref [2]. 
KM = Al/25.0 + 0.5 
XM = KM 

IF (KN.GT.KM) KFLAG = 1 
IF (IA.LE.70.0) KFLAG = 0 

C... Calculation of H(E) as in Equation (34a) of ref [2]. 
FM = FE 

IF (KN.LE.4) FM = (El/420 . 0) ** (0. 72 - 0 . 18*XM) *H3 

IF (FM.GT.1.0) FM = 1.0 

IF (EI. LT. 200.0) FM = FM*El/200.0 

C... Calculation of cross section as in Equation (33b) of ref [2]. 

QH = 0.2 + 60.0* (EXPF (-( (AI - 89 . 0) /25 . 0) **2 - ( (XN-4 . 6 ) /2 . 0) **2 ) 
& + (1.0 - EXPF(-(AI/135.0)**3) )* 

& EXPF(-((XN - AI**0.46) /AI**0.27) **2) ) 

HM = 0.2 + 60. 0* (EXPF(- ( (AI-89.0) /25.0) **2- ( (XM-4 . 6) /2 .0) **2) 






& + (1.0^BXPF(- (AI/135.0)**3) )♦ 

fic EXPF(-((XM - AI**0.46) /AI**0.27) **2) ) 

Determination of d as described below Equation (23) of ref [2] 
IF (KN.EQ.O) DX = -10.0 
IF (KN.EQ.l) DX = -3.0 



IF (IA.LE.70) GO TO 100 

IF (KN.LE.2) QH = ( 1 . 2E5/AJ* *2 . 2 ) *0.12 *EXPF (XN/O . 8 5 ) 

IF (KN.GE.3 .AND. I2.LE.26) QH= ( 1 . 2E5/AJ**2 . 2 ) *EXPF ( {XN-2 ) /2 . 0 ) 
4 IF ((J2.LT.82 .AND. KN.GT.KM) .OR. (IZ.GE.88 .AND. JP.GT.3)) 
& KFLAG = 1 

QH = 0.1** (JP - 3) *QH 

HM = 0.1** (JP - 3) *HM 
6 IF (EI.GE.EC) FE = 1.0 



C... Calculation of Y(A,Z) as in Equation (22) of ref [2] and Equation (3) 

C. . . of ref [3] . 

IF ((DX*(AI-AM)) .LE.O) YA = EXPF (DX* (AI - AM)/ZI) 

IF ((DX*(AI-AM)) .GT.O) YA = 2.0 - EXPF ( -DX* (AI -AM) /ZI ) 

IF (JP.GE.3 .AND. IA.LE.70) YA = 1.0 



n 



C... Y(A,Z) includes correction factor phi{A,E) as in Equation (38) 
C. . . of ref [2] . 
C. . . 

10 IF (IA.GT.157 .AND. EI.GT.500 .AND. ( JP*KN) . NE . 1 ) 
& YA = YA*(1.0 - 0.012*(AI-157.0)*(1,0 - 

& EXPF(- ( (EI-500.0)/290.0)**2) ) ) 

& *(1.0 - EXPF(-0.6*(1.0*JP)**0.8- ((92.0-ZI)/2.7)**2)) 

C... A product with a nucleus at least as large as carbon's or if it's at 
C... least as large as beryllium's with an incoming nucleus greater than 88, 
C... we'll handle it later. 

IF (JP.GT.5 .OR. (JP.GT.3 .AND. IZ.GE.88)) GOTO 100 
QH = QH*YA 

C. . . Calculation of cross section as in Equation (37) of ref [2] . 
^ IF (IZ.EQ.92 .AND. JZ.EQ.88) QH = 1 . 2 *EXPF ( - 0 . 70*ABS ( JA - 224.0)) 

IF (IZ.EQ.92 .AND. JZ.EQ.89) QH - 1 . 6*EXPF ( - 0 . 15*ABS ( JA - 224.0)) 
Cl (I2.EQ.92 .AND. JZ.EQ.90) QH = 8 . 0*EXPF ( - 0 . 2 5*ABS { JA - 233.0)) 

IF (IZ.EQ.91 .AND. JZ.EQ.91) QH = 18 . 5*EXPF ( - 0 . 55*ABS ( JA - 234.0)) 
IF (IZ.EQ.92 .AND. JZ.EQ.9) QH = 55 . 0*EXPF ( - 0 . 80*ABS ( JA - 237.0)) 

QJ = QH*FE 
HM = HM*YA 
QM = HM*FM 

IF (KFLAG. EQ.l) GO TO 100 
GO TO 200 



s = i 

= — h. 



C... Calculation of EO as in Equation (3) of ref [1] . 
100 EC = E0*AI**E1 

IF (EC. GT. 4000.0) EC = 4000.0 

C. . . 

C... (see end of subroutine) 

IF (lA.GT.lOO) FP = 1. - 0.20* (IA-100) /lOO. 
IF (IA.GT.180) FP = 0.84 



AN2X = AMIN1(AN2J,ANZI) 
ANZC = ANZJ - CN 



IF (ANZC.GT.1.5 
AZ = ANZJ 
EE = 450.0/EI ' 




ZC = 1.5 



Calculation of f_FU(E) as in Equation (20a) of ref [2] . 

IF (JA.GT.36 .AND. JZ.LT.88 .AND. IZ.EQ.92) 
& FF = EXPF(33.0* ( (ANZJ - 1.36) + 0 . 00006*EI - 1200 . 0/ 

& (EI+80.0) **2) ) 

IF (JA.GT.36 .AND. JZ.LT.88 .AND. IZ.EQ.90) 
& FF = EXPF(16.0*EE**0.6* ( (ANZJ - CN) + 0.00006*EI - 

& 1200.0/ (EI + 80)**2) ) 

IF (JA.GE.36 .AND. JZ.LT.IZ .AND. IZ.GE.84 .AND. IZ.LT.90) 
& FF = EXPF(19.0*EE**0.6* ( (ANZX - CN) - ALOG ( 5 . 5/EI**0 . 07 ) ) ) 



Determination of g as on p. 349 of ref [2] . 
GE = EE 

IF (EI. LE. 200.0) GE = 2.25 

Determination of h as on p. 34 9 of ref [2] . 
HI = AJ - 105.0 + 0.68*(207.0 - AI) 

IF (EI. GT. 450.0 .AND. EI. LT. 600.0) HI = 0 . 0006*H1* (600 . 0 - EI) 
IF (EI. LE. 450.0) HI = 0.0900*H1 

IF (EI. GE. 600.0 .OR. AI.LT. 180.0 .OR. Hl.LT.O) HI = 0.0 

Determination of portion of f_F(E) as shown in Equation (13) of ref 
AE = 0.0065*(207 - lA) *EXPF ( -ABS (EI - 700 . 0 ) /700 . 0 ) 

Calculation of f_F(E) in Equation (5) of ref [2]. 

IF (lA.GE.llO .AND. IZ.LE.83 .AND. JZ.LT.IZ) 
& FF = EXPF(19.0*EE**0.6* ( (ANZX - CN) - ALOG ( 5 . 5/EI**0 . 07) - AE) 
& -(((AJ/AI - 0.46)/0.15)**2*GE+Hl) ) 

IF (lA.GE.llO .AND. IZ.LE.83 .AND. JZ.LT.IZ .AND. 
& (ANZX - CN) .LT.1.3) FF = 

& FF*EXPF( (1.3 -ANZX + CN) * ( 350 . O/EI ) * *4/ ( 1 . 0 + (130 . O/EI) **4) ) 

IF (FF.GT.FMAX) FF = FMAX 

Determination of f_B(E) as in Equation (14) of ref [2]. 
IF (JZ.GE.88) GO TO 110 
EE = EI/EC 
A4 = (Al/63.0)**4 

IF (EE.GE.0.3) FE = EE** (2.2 - 0.01*A4) 

IF (EE.LT.0.3) FE = EE**(2.2 + 0 . 01*A4 ) *0 . 3 * * ( - 0 . 02*A4 ) 
IF (JZ.GE.5 .AND. JZ.LE.8) FE = EE**1.8 
IF (JZ.GE.9 .AND. JZ.LE.IO) FE = EE**2.0 
GF = 1.0 

EX = EI . 
IF (EX .LT. 500.0) EX = 500.0 

Determination of G as in Equation (15) of ref [2] . 

IF(JA.GE.18 .AND. JA.LE.30) 
& GF = EXPF (2600. 0* ( (ANZX - CN) + 0.01*AI - 3.1) /EX) 

IF(JA.GE.31 .AND. JA.LE.56) 
& GF = EXPF (5600. 0* ( (ANZX - CN) + O.0035*AI - 1.72) /EX) 

IF(GF.LT.l.O) GF = 1.0 

f_B(E) as in Equation (14) of ref [2]. 
FE = FE*GF 

IF{JZ.LT.30 .OR. IZ.LE.83) GO TO 140 



URANIUM GROUP, ZP .GT. CU 



c 




As the various references suggest that data* for very large nuclei is 
sparse at best, I have no idea where these next few lines came from, 

... save that they are used to modify the parameter eta (called CJ) 

110 FU = 1,0 

IF (IZ.GE.88 .AND. JZ.GE.82 .AND. (KN.GT.KM .OR. JP.GT.3)) 
& FU = (1.0 - EXPF(-0.6* (1.0*JP)**0.8 - ((92.0 - ZI)/2.7)**2)) 

& *(1.0 - 0.8*(EXPF(-((2I - ZJ)/5.4)**8) ) ) 

IF (IZ.GE.88 .AND. JZ.GE.57 .AND. JZ.LT.82) FU = 

& 1.0 - 0.36*EXPF(-((82.0 - ZJ)/27.0)**2 - ( ( 92 . 0-ZI) /2 . 7) **2 ) 

CJ = CJ*FU 



C. . . Calculation of cross section as per Equation (18) of ref [2] . 
120 IF(J2.GE.30 .AND. JZ.LE.35) 

& QH = 6.5*EXPF(-80.0* (AN/2J - 1.26)**2)*PN 

IF(JZ.GE.36 .AND. JZ.LE.43) 
& QH = 10.0*EXPF(-55.0* (AN/ZJ - 1.33)**2)*PN 

IF(JZ.GE.44 .AND. J2.LE.50) 
& QH = 10. 0*EXPF (-70.0* (AN/ZJ - 1,36)**2)*PN 

IF (J2.LE.50) GO TO 130 

C... This is mostly described in Equation (18d) of ref. [2] including the 
C... discussion following the equation about extrapolation into regions of 
C. . . nuclei larger than Z > 55. 
EE = EI - 100 

IF (EE. LT. 150.0) EE = 150.0 

HE = 0.03*(ALOG(EE))**2 . Equation (20b) of ref [2] 

IF (HE.GT.1.0) HE = 1.0 
ZZ = JZ 

IF (JZ.LT.55) ZZ = 55.0 

HS = (1.5*EXPF(-1.0/ZJ* (ZZ - 55.0)**2) + 3.0)*FU*HE 
HF = 5.0*EXPF(-10.0/ZJ* (ZZ - 55.0)**1.5) 

CON = 80.0 + 220.0*(1.0 - EXPF(-(ZJ - 55 . 0) **2/4 . 0) ) * ( JZ/55) 

IF(JZ.GE.51 .AND. JA.LE.155) 
& QH = HF*EXPF( -CON* (AN/ZJ - 1.48)**2)*PN 

& + HS*EXPF(-260.0* (AN/ZJ - 1.29)**2)*PN 

IF(JZ.GE.66 .AND. JZ.LE.87) GO TO 140 

IF (IZ.LT.88) GO TO 140 

QJ = QH 

C... Correction for Z = 89 and Z = 90; see p. 353 of ref [2]. 
IF (IZ.LE.90) QH = 0.6*QH 

130 QF = QH*FF 
QJ = QF 
GO TO 200 



C... Calculation of f (A) as in Equations (10) and (13) of ref. [2] (see 
C. . . discussion in section (f) of ref [3]). 
140 IF (IZ.GE.29 .AND. JZ.EQ.5) FA = EXPF ( 0 . 02* (AI - 56) * (ANZC - 0 6)) 
IF (IZ.GE.29 .AND. JZ.GE.6 .AND. JZ.LE.8) 
& FA = EXPF (0.020* (AI - 56 . 0) * (ANZC- 0 . 7 ) ) 

IF (IZ.GE.29 .AND. JZ.GE,9) 
& FA = EXPF(0.020* (AI - 56 . 0 ) * (ANZC- 0 . 9) ) 

IF (JZ.LE.ll) FA = FA* EXPF (-2. 5* (ANZC - 1.0)) 
IF (FA.LT.1.0) FA = 1.0 



C. 
C. 



See Table 1 of ref [2], which determines regions of applicability for 
the various ways of calculating the cross section. 
IF (lA.GE.llO) FM = FF 




IF (IA.LT.HO^BPM = FE 

IFdA.GE.llO .AND. JA.LT.57 .AND. AJ.GT. (0 . 23*AI) ) 
& FM = AMAX1(FE,FF) 

IFdA.GE.llO .AND. JA.LT.57 .AND. AJ . LE . ( 0 . 23*AI ) ) FM = FE 



Determination of Delta A_c as in Equation (2) of ref [1] . 
DMAX = 31.5 + 0.045*(AI - 36 . 0 ) * (ALOG (AI ) + 1.23) 
AC = DMAX 
AE = AC 
AH = DA 

IF (AH. GT. DMAX) AH = DMAX 

IF (EI.LT.EC) DMAX = 31.5 + Dl* (AI - 36 )* (ALOG (EI) - D2) 
AE = DMAX 

IF (DA. GT. DMAX) DA = DMAX 

Calculation of fl as in Equation (4) of ref [1] . 
Fl = EXPF{-0.25 + 0.0074*AI) 

IF (EI. GT. 750.0) Fl = 1.0 + (Fl - 1.0)*({EC - EI)/(EC - 750.0))**2 
IF (EI.GE.EC) Fl = 1.0 



Calculation of f2 as in Equation (5) of ref [1] . 
F2 = EXPF(1.73 - 0.0071*EI) 
IF (F2.LT.1.0) F2 = 1.0 

Calculation of parameter P in Table ID of ref [1] . 
PE = P2/EI**P3 
PH = P0/AI**P1 



Calculation of Cp as below Table ID of ref [1] . 

IF {IZ.GE.20 .AND. IZ.LE.30) 
& PE = PE*{1.0 - 0.32*EXPF(- ( (EI - 100 . 0 ) /lOO . 0) **2 ) ) 

IF (lA.GT.lOO) 

& PE = PE*(1.0 - 0.000015*(AI - 100.0)*(EC + 150.0)/(EI + 150.0)) 

IF (IA.LE.71 .AND. EJ.GE.EC) PE := PH 

IF (IA.GT.72 .AND. EJ . GT . 3000 . 0 ) PE = PH 

IF (EJ.GE.EC .AND. EJ . GE . 3000 . 0 ) PE = PH 

PX = 0.0980* (1000. 0/EJ)**(0.819*ALOG{AI) - 2.732) 

IF (EJ.GT.IOOO. 0 .AND. EJ. LT . 3000 . 0) PE = PX 

PA = PE * AI 

HA = PH * AI 

Determination of parameter R of Table ID of ref [1] . 

RJ = RO*AJ** (-R1) * (1.0 - 0.4*(IZ/88)) 

IF {AJ.IiT.40.0) RJ = R2*AJ**R3* (1.0 - 0.4*(IZ/88)) 



Calculation of A' as discussed below Equation (2a) of ref [2] . 
IF (AA.LT.AC .AND. JZ.EQ.40) DM = -1.1 
IF (AA.LT.AC .AND. JZ.EQ.42) DM = 0.8 



IF 


(AA.LT 


.AC 


.AND. 


JZ. 


EQ. 


S3) 


DM 




-0.5 


IF 


(AA.LT, 


.AC 


.AND. 


JZ. 


EQ. 


55) 


DM 




1.7 


IF 


(AA.LT. 


.AC 


.AND. 


JZ. 


EQ. 


60) 


DM 




-1.1 


IF 


(AA.LT. 


.AC 


.AND. 


JZ. 


EQ. 


61) 


DM 




-1.3 


IF 


(AA.LT. 


■ AC 


.AND. 


JZ. 


EQ. 


63) 


DM 




0.9 


IF 


(AA.LT. 


AC 


.AND. 


JZ. 


EQ. 


64) 


DM 




0.7 


IF 


(IZ.GT, 


,76 


.AND. 


JZ. 


GT. 


62) 


DM 




DM + 1.0 


AJ 


= AJ + 


DM 


















C. . . Determination of parameter S in Table ID of ref tlj . 
S = SO - SI* (AI - AM) /ZI 

C. . . This modified version of the atomic number of the secondary nucleus 
C... doesn't seem to have a counterpart description in any of the papers. 
ST = ZJ - (S - T2*AJ - T3*AJ*AJ)*AJ 
IF (ST.LT.-l.O) ZA = ABS (ST) **1. 30 
IF (ST.GE.-l.O) ZA = ABS (ST) **1. 50 
IF (ST.GT. 1.0) ZA = ABS (ST) **1. 75 

C. . . Calculation of cross section as in Equation (1) of ref [1] . 

QO = C1*F1*F2*PE*AI**C2/ (1.0 - C3/PA - (C4 - C3/PA) *EXPF ( -PA) ) 
HO = C1*1.0*PH*AI**C2/(1.0 - C3/HA - (C4 - C3 /HA) *EXPF ( -HA) ) 
QR = CJ*PN*EXPF(-PE*DA - RJ*ZA) *Q0 
QH = CJ*PN*EXPF(-PH*AH - RJ*ZA) *H0 

C. . . Evaluation of AO as discussed in Equation (16) of ref [3] . 
AX = 0.5* (S - SQRT(S*S - 4 . 0*T2*ZJ) ) /T2 - DM 

C. . . Evaluation of xO somewhat as in Equation (15) of ref [3] . 
KX = (AI - AX) - (JP - 1) 
XP = KX 

IF (IA.GT.70 .AND. KN.GT.KM .AND. KN.LT.KX .AND. KFLAG.EQ.l) 
& GO TO 20 

GO TO 195 

Calculation of fl as in Equation (4) of ref [1] . 

FIOOO. = 1.0 + (EXPF(0.0074*AI - 0.25) - 1.0)* 
& ( (EC-1000. 0) / (EC - 750.0))**2 

Calculation of cross section as in Table ID and Equation (1) of ref [2] . 

QIOOO = CJ*PN*C1*F1000*AI**C2*P1000*EXPF(-P1000*DA-RJ*ZA) 
& /(l.O - C3/P1000/AI - (C4 - C3/P1000/AI) *EXPF(-P1000*AI) ) 

Ly C. . . Cross section calculated with different DELTA A. 

M XIOOO = Q1000*EXPF{-P1000* (AI - AX) ) /EXPF ( -P1000*DA - RJ*ZA) 

\j C. . . Yet another correction to the cross section. 

HR = QH*EXPF(-PH* (AI - AX) ) /EXPF { -PH*AH - RJ*ZA) 
IF (XIOOO. GT.HR) XIOOO = HR 

C. . . Repeat above procedure to calculate different cross section, but for 
C. . . a different energy. 

F500 = EXPF(0.0074*AI - 0.25) 

Q500 = CJ*PN*C1*F500*AI**C2*P500*EXPF(-P500*DA - RJ*ZA) 
& /(l.O - C3/P500/AI - (C4 - C3/P500/AI) *EXPF(-P500*AI) ) 

X500 = Q500*EXPF(-P500* (AI - AX) ) /EXPF ( -P500*DA - RJ*ZA) 
QR = QR*EXPF(-PE* (AI - AX) ) /EXPF ( -PE*DA - RJ*ZA) 
IF (EI.GT.EC) QR =: HR 

IF (EI. GE, 1000.0 .AND. QR. GT.HR) QR = HR 
IF (EI. LT. 1000.0 .AND. EI. GT. 500.0) 
& QR = X500 + (XIOOO - X500)*(EI - 500.0)/500.0 

QH = HM + (HR - HM)*(XN - XM) / (XP .- XM) 
QJ = QM + (QR - QM)*(XN - XM) / (XP - XM) 
KFLAG = 0 
GO TO 200 

195 KFLAG = 0 



IF (EJ.GT.EC)^iF = QH 

IF (EI. GE. 3000.0 .AND. QR.GT.QH) QR = QH 



C... Repeat procedure described above, but for different circumstances. 
F500 = EXPF(0. 0074*AI - 0.25) 

Q500 = CJ*PN*C1*F500*AI**C2*P500*EXPF(-P500*DA - RJ*ZA) 
& /(l.O - C3/P500/AI - (C4 - C3/P500/AI) *EXPF(-P500*AI) ) 

FIOOO = 1.0 + (EXPF(0.0074*AI - 0.25) - 1 . 0) * ( (EC- 1 . 0E3 ) 
& / (EC-750.0) ) **2 

QIOOO = CJ*PN*C1*F1000*AI**C2*P1000*EXPF{-P1000*DA - RJ*ZA) 
& /(l.O - C3/P1000/AI - (C4 - C3/P1000/AI) *EXPF(-P1000*AI) ) 

F3000 = 1.0 + (EXPF(0.0074*AI - 0.25) - 1.0)* 
& ((EC - 3.0E3)/(EC -750.0))**2 

Q3000 = CJ*PN*C1*F3000*AI**C2*P3000*EXPF{-P3000*DA - RJ*ZA) 
& /(l.O - C3/P3000/AI - (C4 - C3/P3000/AI) *EXPF (-P3000*AI) ) 

FDAE = AMIN1((AI - AJ) / (0 . 14*AI) * (El/lOOO . 0) ** ( -2 . 0/3 . 0) , 2 . 0) 







IF 


(IZ.GE.29 . 


.AND. IZ.LE.83 .AND. EI.LE.1.0E3) QR = QR*FDAE 






IF 


(IZ.GE.29 . 


.AND. IZ.LE.83 .AND. EI.GT.1.E3 .AND. EI.LE.3.0E3) 






& 


QR = 0. 5* (3 .0*Q1000 - Q3000) + (Q3000 - QIOOO) /2000 . 0*EI 






QJ 


= QR 








Ql 


= QR 








IF 


(IZ.LT.88 . 


OR. JP.GT.3) GO TO 160 






QJ 


= QR*FU 








GO 


TO 200 






160 


DD 


= AC - AA 






C. . . 


Calculation of 


(N/Z)c as in Equation (3) of- ref [2] . 






XZ 


= 1.29 + 0. 


005*DD + CN 






IF 


(QH.GT.0.0) 


RH = QR/QH 






IF 


(GF.GT.0.0) 


FR = FE/GF 




C. . . 


Calculations for different regions as discussed in Table 1 of ref 






IF 


(IA.GE.69 . 


AND. RH.LT.FR .AND. EI. LT. 300.0) QR = QH*FR 


yj 




IF 


(IZ.GE.76 . 


AND. IZ.LE.80) FF = FF*AMIN1 (1050 . 0/EI + EI/EC,6.0) 






IF 


(lA.GE. 110 


.AND. IA.LE.238) QF = QH*FF*FA 






IF 


(IA.GE.69 . 


AND. JA.LE.57) QE = QH*FE*FA 






IF 


(lA.LT. 110. 


OR. IA.GT.209 .OR. JA.LE.56) GO TO 190 




IF 


(DD.GE.20) 


GO TO 170 






IF 


(lA.LE. 125) 


GO TO 180 






IF 


(AZ.LE.XZ . 


OR, JZ.GT.57) GO TO 170 






KZ 


= 51 + IZ/76 + IZ/80 






IF 


(AZ.GT.XZ . 


AND. JZ.LT.KZ) GO TO 180 



C. . . Calculation of exponent gamma as described below Equation (7) of ref [2] 
C. . . and in Equation (19) of ref [3] . 
ER = EI** (2.0/3.0) 

IF (ANZC.LT.1.56) GA = (0.03 + (ZJ - KZ) *0 . 007 ) * ( 1 . 56 - ANZC) *ER 
IF (ANZC.GE.1.56) GA = 0 
IF (GA.GT.1.0) GA = 1.0 

C... Calculation of cross section as in Equation (7) of ref [2]. 

IF (JZ.GE.KZ .AND. JZ.LE.57 .AND. DD.LT.20.0 .AND. AZ.GT.XZ) 
& QJ = QR**GA*QF** (1.0 - GA) 

GO TO 200 



C... Cross sections for different regions as discussed in Table 1 of ref [2], 
170 QJ = QR 



GO TO 200 



i80 QJ = AMAXKQR, QF) 
GO TO 200 

C. , . More regions discussed in Table 1 of ref [2] . 
190 IF(IA.GE.210 .AND. JA.GE.57) QJ = QF 

IFdA.GE.llO .AND. JA.LE.56 .AND. AJ. GT . (0 . 23*AI) ) QJ = QH*FA*FM 
IFdA.GE.llO .AND. JA.LE.56 .AND. AJ . LE . ( 0 . 23*AI ) ) QJ = QE 
IFdA.LT.llO .AND. IA.GE.69 .AND. DD.GE.O) QJ = QR 
IFdA.LT.llO .AND. IA.GE.69 .AND. DD.LT.O) QJ = QE 
IF{IA.LT.69) QJ = QR 

C... Situation described in Equation (18d) and below in ref [2]. 

IF (QJ.EQ.QR .AND. QI.GT.O.O) QH = QH*QR/QI + 0.000001 

IF dZ.GE.90 .AND. J2.GE.66) 
& QJ = HF*EXPF(-CON* (AN/J2 - 1 . 48) **2 ) *PN* (0 . 6 + 0.2* {12 - 90)) 

& + HS*EXPF(-RJ*ZA) *PN* (0.6 + 0.2* (IZ - 90)) 

C. . . Deteirmination of exponent gamma. 

IF (QJ.EQ.QE .OR. QJ.EQ.QF) GA = 0.0 
IF (QJ.EQ.QR) GA = 1.0 

IF (JP.LT.3 .OR. JP.GT.5) GO TO 2 00 

C... Determination of H* (E) as in Equations (34a) and (34b) of ref [2]. 
FE = 1.0 - EXPF(- (EI/35.0) **4) 
IF (EI .LT. 200.0) FE = FE*El/200.0 

IF (JP.GE.3 .AND. KN.GE.l .AND. IA.LE.70) GO TO 200 

C. - . 

IF dZ.GT.30.AND. JP.GE.3 .AND. KN.GE. KM) GO TO 200 
QJ = QH*FE*YA 

C... Calculation of E' as used in ref [3] ; 
C. . . justification of equation not found, however. 
200 EX = E0*56 . 0**E1*EJ/EC 

C... Determination of correction factor fl as in Equation (3) of ref [3]. 
Gl = 1.0 - 0.6*(1.0 - EXPF(-(EX/1000.)**2))*EXPF(-(EX/2000.0)**2) 
& + 0.2*(1.0 - EXPF(- (EX/3000. 0)**2) ) 

C... Determination of correction factor f2 as in Equation (9) of ref [3]. 
G2 = 1.0 - 0.4*(1.0 - EXPF(- (EX/2000.0) **2) ) * 
& EXPF(-((EX - 1800.0) /1800.0) **2) 

& + 0.17*(1.0 - EXPF(- (EX/2000.0) **2) ) 

C... Determination of correction factor f3 as in Equation (10) of ref [3]. 
G3 = 1.0 + 0.25*(1.0 - EXPF(- (EX/1500.0) **2) ) * 
& EXPF(-((EX - 1500. 0) /1800.0) **2) 

& - 0.05*(1.0 - EXPF(- (EX/2000.0) **2) ) 

C... Determination of correction factor f4 as in Equation (11) of ref [3], 
G4 = 1.0 - 0.1*(1.0 - EXPF(- (EX/4000. 0)**2)) 

C, Application of correction factors as described in part (b) of ref [3]. 
IF d2.LE.28 .AND. J2.LE.4 .AND. JA.LE.12) QJ = QJ*G1 
IF d2.LE.28 .AND. AA.GT.AC) QJ = QJ*G2 



c 
c 
c 
c 

c. 




IF {IZ.GT.28 JA.LE.56 .AND. AA.GT.AC) QJ ^^J*G2 

IF (AA.GE.7.0 .AND. AA. LE . (AC- 13 . 0) ) QJ = QJ*G3 
IF (IZ.GE.90 .AND. JA.GT.56 . AND . AA . GE . 7 . 0) QJ = QJ*G4 

C... Correction for when the change in the number of neutrons is much larger 
C... than the change in the number of protons. 



MX 


= 10 


















IF 


(lA.LT. 


.150 .AND. JP.LT.3) MX = 


9 












IF 


(lA.GE. 


.150 .AND. JP.EQ. 3) MX = 


11 












IF 


(JP.EQ. 


, 1 . 


AND. KN.GT.MX) QJ = 














& 






QJ* (0. 


.1 +0. 


. 9*EXPF(- 


(XN - 


MX) 


**2/4 , 


.0)) 


IF 


(JP.EQ. 


2 . 


AND. KN.GE.MX) QJ = 














Sl 






QJ* ( 0 , 


,1+0, 


, 9*EXPF(- 


(XN - 


MX) 


**2/4. 


.0)) 


IF 


(JP.EQ. 


3 . 


AND. KN.GE.MX) QJ = 














& 






QJ* (0. 


5 +0. 


, 5*EXPF(- 


(XN - 


MX) 


**2/4. 


.0)) 



QJ = QJ*FP 

RETURN 
END 



SUBROUTINE PXN(Z, A, X, E, QJ) 



; ) 

! ; 

™ p 

fU 

C... This subroutine is for the case where the incoming nucleus is 
H C... for elements between scandium and uranium and the secondary 
'^"^^ C. . . nucleus is between boron and the incoming nucleus, i.e., 

C... 21 .LE. IZ .LE. 92 .AND. 5 .LE. JZ . LE . IZ 

= C. . . 

c 

ru c 

W COMMON /A/ Ql, Q2, QI , Fl, F2 , F3 

H EI = 500.0 + 300. 0*X 

m 01= 3.3*EXPF(-ABS(6.9 - X) **2 . 8/67 . 4 5 - 

& 90.0*X**2.35*ABS(2.5 - A/Z)**5) 

QA = 3.3*EXPF(-ABS(6.9 - X) **2 . 8/67 . 45 - 0 . 04638*X**2 . 35) 
QB = 3.3*EXPF(-ABS(6.9 - X) ♦*2 . 8/67 . 45) 
IF (A/Z.GE.2.28 .AND. A/Z.LE.2.50) 
& Ql = QA**((2.5 - A/Z)/0.22) * QB** ( (A/Z - 2.28)/0.22) 

IF (A/Z.GT.2.5) Ql = QB 
QI = Ql 

XZ = ( (A - Z) - X + 1)/Z 

Q2 = 0.5*EXPF(-90.b*ABS(i.5-XZ)**5) 

IF (XZ.LE.1.2) QI = AMINKQl, Q2) 

IF (Z.GE.81.0) FI = 1.5*EXPF(-X* ( (Z - 80 . ) /12 . 0) **5) 

IF (FI.GT.1.0) FI = 1.0 

IF (Z.GE.81.0) QI = QI*FI 

IZ = Z + 0.1 

NX = X + 0.1 

lA = A + 0.1 

NT = lA - IZ 

N = NT - NX 

ED = E 

IF (NX.GE.3 .AND. IZ.GE.39 .AND. NT.GE.28 .AND. N.LT.50) 
& ED = E - 10.0 



IF (NX.GE.3 .ll^ IZ.GE.59 .AND. NT.GE.50 .AND^^LT.82) 

& ED = E - 3.0 

B = A 

IF (B.LT.35.0) B = 35.0 

FX = (12.0 + 0.1*X)*X - (1.0 - 1.0/X**0.5)*B**(2. 0/3.0) 

ALOGY = (1.0 + 1.5*X)*AL0G(ABS (ED/FX)) 

IF (ALOGY. GT. 10.0) AIiOGY=10.0 

Fl = 1.0 - EXPF (- EXP (ALOGY) ) 

C = 1.0 + 0.03*X* (A-208.0) 

IF (CLE. 1.0) C = 1.0 

D = 27.5 - 0.1*(A + (200.0 - A)/X**0.5) 
IF ((1.0 - X)*(208.0 - A).GT.0.0) D = 

& D - 0.03*(1.0 - X)*(208.0 - A) 

F = E 

IF (NX.GE.3 .AND. IZ.GE.39 .AND. NT.GE.28 .AND. N.LT.50) 
& F = E - 3.0 

IF (NX.GE.3 .AND. IZ.GE.59 .AND. NT.GE.50 .AND. N.LT.82) 
& F = E - 3.0 

IF (NX.EQ.l .AND. I2.GE.79 .AND. IZ.LE.83) F = E + 5.0 

F2 = 3500/C * EXPF(-0.6*X - 0.5*{({F - D) - 5 . 0*X**1 . 34 ) / 
& (6.0 - 2.5/X**4) ) **2) 

Sc * (1.0 - EXPF(- (0.03*A/ (2.0 - 1 . 0/X**4) ) **3 ) ) 

G = 0.01* (A - 208.0) 

IF (A. LT. 208.0) G = 0.0 
□ F3 = (1300. 0/(E + 20.0*X**1.5/E) ) ** (1.3 - G) 

FH = (1300.0/{EI + 20,0*X**1.5/EI) ) ** (1.3 - G) 
f=l FE = Fl* (F2 + F3) 

Q IF (E.GE.EI) QJ = FH*QI 

^1 IF (E.LT.EI) QJ = FE*QI 

Q IF (Z.EQ.6.0 .AND. (A-X+1 . 0) . EQ. 13 . 0) QJ=QJ*0.4 

IF {Z.EQ.3.0 .AND. (A-X+1 . 0 ) . EQ . 9 . 0 ) QJ = QJ*0.65 

I" RETURN 
f". END 
C 

jy c 
UJ c 
M c 

FUNCTION EXPF(X) 
Si IF (X.LT.-23.0) X = -23.0 

IF (X.GT.23.0) X = 23.0 
EXPF = EXP(X) 
END 



SUBROUTINE ZTOTBE (ELOWER, EUPPER, M, IZLO, I ZUP , TARGET, PSTEP) 

C SUBROUTINE ZTABLE in Module UPROP.FOR 
C 

C Creates the auxiliary ionization loss data file (ZTABLE.DAT) . 
C 

C Modified by AJT 5-8-96 to remove examination of old files. 
C 

C Parameters 
C 

C MARR Maximum number of logarithically- spaced energy bins in spectrum 

C ELOWER Lower energy bound of input and output spectra (>= 0.1 MeV) 

C EUPPER Upper energy bound of input and output spectra (<= 100000 MeV) 

C M Number of logarithmically equally- spaced energy bins (<= MARR) 

C IZLO Least atomic number of elements transported (>= 1) 

C IZUP Greatest atomic number of elements transported {<= 109) 

C TARGET Name of the target shielding material (>= 12 bytes) 

C PSTEP A small pathlength over which 2 nuclear fragmentations are 

C unlikely, typically 0.1 g/cm**2. 

C 

C Important variables 
C 

C E Energy at each grid point after shielding (MeV) 

C S Stopping power at each grid point after shielding (initially) 

C Ratio of stopping powers before and after shielding (modified) 

C R Range at each grid point after shielding (initially) 

C Range at each grid point prior to shielding (modified) 

C EP Energy at each grid point prior to shielding 

C SP Stopping power at each grid point prior to shielding 

C RP Range at each energy EP 

C 

C Subprograms 
C 

C SUBROUTINE RANGE (E , M, Z , A, TARGET, R) 

C Returns the range R(M) at M energy grid points E(M) for an element with 

C charge Z and mass A in target material TARGET 

C 

C FUNCTION STPOW(E,Z, A, TARGET) 

C Returns the stopping power STPOW at energy E for an element with charge 

C Z and mass A in target material TARGET 

C 

C BLOCK DATA DOl 

C Defines the atomic masses of elements in the range 1 <= z <= 109 and 

C places them in the array AMASS 

C 

C Data File 
C 

C ZTABLE.DAT 

C Contains ionization loss data for the transport calculation. 
C Automatically created by this subroutine when needed. 

PARAMETER (MARR=5000) 

REAL*4 E (MARR) , S (MARR) , R (MARR) , EP (MARR) , SP (MARR) , RP (MARR) 
CHARACTER* 12 TARGET, TARGET$ 
INTEGER*4 STAT,CREME96 OPEN 



COMMON/MASS /AMASS (109) 




: ; J 



DATA IiMAX,MA3PiRS/2,10/ 
DATA ELOWER$ , EUPPER$ , M$ , IZLO$ , I2UP$ , TARGET$ , 
& PSTEP$/0. ,0. ,0,0,0, ' ',0./ 

C FORMAT Statements 

100 FORMAT(1X,2(1PE10.4,2X) ,3(I5,2X) , A12 , 2X, IPEIO . 4 ) 
200 FORMAT { ( IX, 6 ( IPElO . 4 , 2X) ) ) 

C OPEN (UNIT=11,FILE=' USER: 2TABLE.DAT' ,STATUS='NEW' ) 

Stat = creme96_open('ztable.dat' , 'user' ,11, 'new' ) 

C Write header 

ELOWER$=ELOWER 
EUPPER$=EUPPER 
M$=M 

IZLO$=IZLO 
IZUP$=IZUP 
TARGET$=TARGET 
PSTEP$=PSTEP 

WRITE (11,100) ELOWER,EUPPER,M,IZLO,IZUP, TARGET, PSTEP 
WRITE (11, ' (A) ' ) ' ' 

C Compute vector of energies 

DE= (EUPPER/ELOWER) ** ( 1 . /FLOAT (M- 1 ) ) 
E(l) =ELOWER 
DO J=2,M-1 

E(J) =E(J-1) *DE 
END DO 
E (M) =EUPPER 

C Compute parameters 

DO J=IZLO,IZUP 
Z=FLOAT (J) 
A=AMASS (J) 

CALL RANGE (E,M,Z, A, TARGET, R) 
DO K=1,M 

S(K)=STPOW(E(K) ,Z, A, TARGET) 
END DO 
DO K=1,M 

DO KK=K,M 

IF (R(KK) .GE.R(K) +PSTEP) GOTO 300 

END DO 

KK=M 

300 EP (K) =E (KK) - (R (KK) -R (K) -PSTEP) *S (KK) 

R(K) =R(K) +PSTEP 
END DO 

C Iterate LMAX times to improve estimate of EP 

DO L=1,LMAX 

CALL RANGE(EP,M, 2,A,TARGET,RP) 
DO K=1,M 

SP (K) =STPOW (EP (K) , Z , A, TARGET) 
EP (K) =:EP (K) - (RP (K) -R (K) ) *SP (K) 
END DO 
END DO 



Compute ratio of stopping powers 



DO K=1,M 

S(K)=SP(K) /S(K) 
END DO 

Write output to ZTABLE.DAT 

WRITE (11,200) {EP{K) ,K=1,M) 

WRITE (11,100) 

WRITE (11,200) (S(K),K=1,M) 

WRITE (11,100) 

END DO 

Close output file and stop 



CLOSE (UNIT=11) 

RETURN 

END 



SUBROUTINE ZTPf GET (LNAME) 
CHARACTER* 12 LNAME 
C INCLUDE 'CREME96 :ZCOMMON.CMN' 

CHARACTER* 12 NAME 

REAL NA(28) ,IADJ(28) ,NASPM(28) , DENS , ETAD 
INTEGER NZ (28) , IGAS , NAS , STAT , CREME96_OPEN 
COMMON /TBLOCK/DENS , ETAD , IGAS , NAS , 
& NZ,NA,IADJ,NASPM, 
& NTOTAL, AVGZ , AVGZ2 , AVGA, AVGI 

! Check to see if current target is LNAME 

IF (LNAME. EQ. NAME) RETURN 

! Open TARGET.DAT and read data for LNAME 

C OPEN (UNIT=10, FILE='CREME96 : TARGET. DAT' , 

c & STATUS = ' OLD ' , READONLY , SHARED ) 

Stat = creme96_open( 'target.dat' , 'cr96tables' ,10, 'old' ) 

1 FORMAT (IX, 13) 

2 F0RMAT{1X,A12, 2X,F9.6,2X, F9.6,2X, I1,2X,I2) 

3 FORMAT (IX, 13 , 2X , F8 . 4 , 2X, F5 . 1 , 2X , F9 . 5) 
READ(10,1) NM 

DO J1=1,NM 

Q READ(10,2) NAME, DENS, ETAD, IGAS, NAS 

DO J2 = 1,NAS 

READ (10, 3) NZ(J2) ,NA(J2) ,IADJ(J2) ,NASPM(J2) 
END DO 

IF (LNAME. EQ. NAME) THEN 
CLOSE (UNIT=10) 
GO TO 100 
ENDIF 
END DO 

CLOSE (UNIT^IO) 

PRINT *,' ***** Target Data not available *****' 
STOP 
100 "CONTINUE 



\-\ 



Compute material parameters 

NTOTAL=0 

AVGZ=:0. 

AVGZ2=0. 

AVGA=0. 

AVGI=0. 

DO JX=1,NAS 

NTOTAL=NTOTAL + NASPM(Jl) 
AVGZ=AVGZ + NASPM ( Jl) *FLOAT (NZ ( Jl) ) 
AVGZ2=AVGZ2 + NASPM (Jl ) *FLOAT (NZ (Jl) ) **2 
AVGA=AVGA + NASPM (Jl) *NA (Jl) 
AVGI=AVGI + NASPM (Jl) *ALOG (lADJ (Jl) ) 

END DO 

AVGZ=AVGZ/FLOAT (NTOTAL) 
AVGZ2=AVGZ2 /FLOAT (NTOTAL) 
AVGA=AVGA/ FLOAT (NTOTAL) 
AVGI=EXP (AVGI/FLOAT (NTOTAL) ) 
RAT=AVGZ/AVGA 



RETURN 
END 



p|^^LUX(IZ, IQ, EN, YEAR) ^^j^ 



REAL FUNCTION P\ 
C 

C Returns the interplanetary anomalous cosmic ray (ACR) flux for element 

C IZ in charge state IQ at energy EN (in MeV/nuc) for year YEAR 

C (ie, decimal year 1987.23) 
C 

C Flux returned in unit of ions/m2-s-sr-MeV/nuc 
C 

C Written by: Allan J. Tylka 

C Code 7654 

C Naval Research Laboratory 

C Washington, DC 20375-5352 

C tylka@crs2.nrl.navy.mil 
C 

C Last update: 25 September 1996 
C 

C 

C 

C This routine based on results from several sources: 
C 

C (1) ACR Elemental Composition 

C Cummings & Stone discovered that all ACR spectra could be mapped 

C to a common spectral shape by using flux and energy scaling factors, 

C contained here in the arrays FFAC and EFAC, respectively. The values 

C of these scaling factors are taken from various sources. Unless 

C otherwise noted, they are given in: 

C Cummings & Stone, Proc . 20th ICRC (Moscow), 3, 413-416 (1987). 

C FFAC values for N, Ne modified to match the interplanetary abundances 

C reported from SAMPEX at 16-25 MeV/nuc : 

C Selesnick et al , , JGR 100, 9503-9518 (1995). 

C 

C He spectrum taken from: 

C Cummings, Stone, & Webber, Ap.J. Lett. 287, L199-L103 (1984), which 

C is based on Voyager observations in 9/1977-2/1978, when the 

C .spacecraft were still near Earth (-1.3-2.5 AU) 
C 

C Relative abundance and spectrum of ACR H at 1 AU estimated by: 

C Mewaldt, Proc. 24th ICRC (Rome)- 4, 808-811 (1995). 

C (The spectrum here roughly matches this.) 
C 

C (2) Spectral shape and distribution of charge states: 
C 

C Based on SAMPEX observations and modeling results presented by 

C R.A. Mewaldt et al., Astrophysical Journal Letters 466, L43-L46 (1996). 

C 

C (3) Temporal variation and solar- cycle modulation: 
C 

C Based on the timeline of 8-27 MeV/nuc oxygen for 1968-1994 as reported 

C by Mewaldt et al . GRL 20, 2263-2266 (1993) and augmented during the 

C 1985-95 time period by Cosmos measurements reported by: Beaujean et al . 

C Proc. 24th ICRC (Rome) 4, 832-835 (1994) . 



IMPLICIT NONE 
INTEGER*4 IZ,IQ,NELM 
PARAMETER (NELM=18) 

REAL*4 EN,YEAR, FPEAK, AMASS, FFAC, EFACENl 

DIMENSION FPEAK (4) ,FFAC(NELM) , EFAC (NELM) , AMASS (NELM) 

DATA FPEAK/3 . 935 , 0 . 3808 , 0 . i014 , 3 . OlE-2/ 

DATA FFAC/3. 6, 4. 9, 3*0. 0,0. 0075, 0.127,1.0,0.0,0.40,7*0.0,0.019/ 




DATA EFAC/9. 0, ^■3*1. 0, 1.38,1. 14, 1.0,1.0,0.64,^Po, 0.36/ 
DATA AMASS/ 

& 1.00794,4.002602,6.941,9.012182,10.811,12.011,14.00674,15.9994, 

& 18.9984032,20.1797,22.989768,24.305,26.981539,28.0855,30.973762, 
& 32.066,35.4527,39.948/ 

REAL*4 A0,Q, AN, FP,BETA,ANORM,EPEAK 

DATA AO/1.70/ 

REAL*4 SMNORM/0. 5534E+4/ 

REAL* 4 ACRO_TIMELINE 

ACR_FLUX=0. 0 

IF (IZ.GT.NELM) RETURN 

IF (FFAC(IZ) .LE.O) RETURN 

IF (EN.LT.l.O .or. EN. GT. 1000.) RETURN 

IF (IQ.GT.IZ) RETURN 



Q=IQ*1.0 

AN=AMASS(IZ) 

IF (IQ.LE.4) THEN 

FP=FPEAK(IQ) 
ELSEIF (IQ.GT.4) THEN 

FP=:3. 935/0**3.52 
ENDIF 

EPEAK=6 . 73*Q**0 . 91 

FP=FP*FFAC(IZ) 

BETA=1 . 0/A0/EPEAK**A0 

ANORM=SMNORiyi*FP/EPEAK/EXP ( - BETA* E PEAK** AO ) 
EN1=EN/EFAC(IZ) 

ACR_FLUX=AN0RM*EN1*EXP ( -BETA*EN1**A0) 

C Solar modulation factor: 

ACR_FLUX = ACR__FLUX * ACRO_T I MEL INE ( YEAR ) 

RETURN 

END 



REAL FUNCTION ACRO_TIMELINE (USERX) 

C 

C Fxmction to model the solar cycle variation of the anomalous 

C component at 1 AU. Based on the timeline of 8-27 MeV/nuc oxygen 

C for 1968-1994 as reported by Mewaldt et al . GRL 20, 2263-2266 (1993) 

C and augmented during the 1985-95 time period by Cosmos measurements 

C reported by: Beaujean et al . Proc. 24th ICRC (Rome) 4, 832-835 (1994) 

C 

C Calculates a y- value, along a line drawn through data points, for a given 
C year (USERX) on Fig. 3 of Mewaldt et al . 

IMPLICIT NONE 
C Argument declarations 
REAL USERX 



C Local declarations 

INTEGER KMAX , I 
PARAMETER ( KMAX= 5 ) 

REAL XVAL(KMAX+1) ,YVAL(KMAX+1) , SLOPE (KMAX) , YEAR 
DATA XVAL /l . 9685E+03 , 1 . 9715E+03 , 1 . 9778E+03 , 1 . 982 5E+03 , 
& 1.9873E+03,1.9903E+03/ 

DATA YVAL /5 . 8651E-09, 1 . 2123E-06 , 2 . 0350E-06 , 6 . 4463E-09, 
& 1.7630E-06,5.8651E-09/ 

DATA SLOPE /l . 782245, 8 . 206459E-02 , -1 . 217980, 1 . 177813 , -1 . 896111/ 



'^d^35E+03 , 1 . 9717E+03 , 1 . 9778E+03 , 



C DATA XVAL /^■J^slfi+O J , 1 . 9717E+03 , 1 . 9778E+03 , ^^25E+03 

C & 1.9873E+03,1^03E+03/ 

C DATA YVAL /5 . 8651E- 09 , 2 . 035E- 06 , 2 . 0350E- 06 , 6 . 4463E- 09 , 

C & 1.7630E-06,5.8651E-09/ 

C DATA SLOPE /l . 782245, 0 . 00, -1 . 217980, 1 . 177813 , -1 . 896111/ 



Evaluate which slope to use and calculate y-value 
CALL ACRO_YEAR (USERX , XVAL ( 1 ) , XVAL (KMAX+1 ) , YEAR) 
DO I=1,KMAX 

IF { (YEAR.GE.XVAL(I) ) .AND. ( YEAR . LT . XVAL (I + l) ) ) 
&^ ACRO_TIMELINE=EXP (ALOG (YVAL (I + l) ) - 

& (SLOPE (I) * (XVAL (I + l) -YEAR) ) ) 

ENDDO 



RETURN 
END 

SUBROUTINE ACRO_YEAR (USERX , LOWERX , UPPERX , YEAR) 

C Evaluates a given year to see if it falls within the range of 1967.9-1990.5 
C If it doesn't, USERX is updated by either adding or subtracting a factor' 
O C of 21.8 so that it does fall within the specified range. 

Q C Declarations 

n IMPLICIT NONE 

m REAL USERX, LOWERX, UPPERX, DIFF,RMDR, YEAR 

□ INTEGER FACTOR 

C Evaluate and modify USERX 
[ IF (USERX .LT. LOWERX) THEN 

DIFF=LOWERX-USERX 

RMDR=DIFF/21.8 
;^ FACT0R=INT(RMDR)+1 

YEAR=USERX+REAL ( FACTOR) * 2 1 . 8 

^ ELSEIF (USERX .GT. UPPERX) THEN 

DIFF=USERX-UPPERX 
RMDR=DIFF/21.8 
FACTOR=INT (RMDR) +1 
YEAR=USERX-REAL (FACTOR) *21.8 



ELSE 

YEAR=USERX 
ENDIF 



RETURN 
END 



c 
c 
c 
c 
c 
c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c- 

c 



REAL*4 FUNCTI^^ENDEL1(A,E) 



Function evaluates the value of the proton-upset cross -section 
at energy E using the Bendel l-parameter inputs 

Inputs: A: Bendel parameter A 

E: proton energy (in MeV) 

Output: SEU cross -section in lOE-12 cm2/bit 



Written by: 



Last update: 



Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 . nrl .navy . mil 

29 March 1996 



IMPLICIT NONE 
REAL*4 Y,A,E 

BENDELl = 0. 

Y = (SQRT(18./A) )*(E-A) 
IF (Y.LT.O.) Y=0. 

BENDELl = ( (24. /A) **14 . ) * ( (1 . -EXP ( - . 18*SQRT (Y) ) ) **4. ) 
IF (BENDELl. LT. 0. ) BENDEL1=0.0 



RETURN 
END 



REAL* 4 FUNC 




BENDEL2 (A,B,E) 




C 
C 
C 
C 
C 
C 



Function evaluates the value of the proton-upset cross -section 
at energy E using the Bendel 2 -parameter inputs 



Inputs : 



A, B: Bendel parameters A and B 
E: proton energy (in MeV) 



C 
C 
C 
C 
C 

c 
c 
c 
c 
c 
c- 
c 



Last update : 



Written by: 



Output : 



SEU cross-section in lOE-12 cm2 



Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 . nrl . navy . mil 



29 March 1996 



IMPLICIT NONE 
REAL*4 Y,A,B,E 

BENDEL2=0 

Y = (SQRT{18./A) )*{E-A) 
IF (Y.LT.O.) Y=0. 

BENDEL2 = { (B/A) **14 . ) * ( (1. -EXP {- . 18*SQRT(Y) ) ) **4 . ) 
IF (BENDEL2.LT.0. ) BENDEL2=0 . 0 



RETURN 



END 




subroutine blccoffds (lat , Ion, alt, year, imod, bobO, L, yearp, B) 

c Inputs: 

c lat, latitude 

c Ion, east longitude 

c alt, altitude in km 

c year, not currently used 

c imod, = 1 for solar min model, = 2 for solar max model (these are the 

c only choices provided for this first version of blccoords) 

c Outputs: 

c bobO returned as Tylka requested (see caveat below where calculated) 

c L 

c yearp, year used by allmag (1964 for solar min, 1970 for solar max) 

c B 

C****** *********** ******♦*★*♦♦ 

implicit none 
save 



real*4 lat. Ion, alt, year, bobO, L, yearp, b 

real*8 lat8, lonS, altS, err8, LB, b8 

integer *4 imod, imodold, model 

^.0 real*8 constem 

Q c ommon / gmagmo / constem 

Q 

f|j data errS/ .1/ 

g data imodold /- 10/ 

; . i 

ij, if (imodold .eq. -10) then ! first time 

imodold = imod 

if (imod .eq. 1) then 
Ui yearp = 1964 

elseif (imod. .eq.2) then 
rj yearp = 1970 

^ else 

^ stop 'blccordsO' 

^ endif 

call stmagdmod, yearp) 
else 

if (imod. ne. imodold) then 
! imod has changed 
stop 'blccordsl' 
endif 
endif 



lat8 = dbledat) 
lonS = dble(lon) 
alts = dble(alt) 

call invara (imod, yearp, latS, lon8, altS, err8, b8, L8) 
b = sngl(b8) 
L = sngl(l8) 

c compute b over bO for Tylka this may not be the bobO value computed and 

c used by the trapped proton models because of checks on data base limits, 

c As an alternative, one can return actual value used from call to 

c subroutine Trapped_protons 

bobO = (b*(L*L*L)/ sngl (constem) ) 



return 
end 






subroutine allmag (model , tm, rkm, st, ct, sph, cph, br, bt, bp, b) 



implicit none 
save 

real*8 ar, aor, b, br, bt, bp, const, cp, cph, ct, dp 
real*8 fn, fm, g, p, par, rkm, sp, sph, st, temp 

real * 4 tm 

integer*4 nmax, m, model, n 

common/magcof / g{14, 14) , fn(14), fm(14) , const (14 , 14) , nmax 
dimension p( 14,14 ) , dp(14,14), sp(14), cp(14) 
datap(l,l), cp(l), dp{l,l), sp(l) / 2*1. ,2*0. / 

sp(2) = sph 
cp ( 2 ) = cph 
do m = 3 , nmax 

sp(m) = sp{2) * cp(m-l) + cp(2) * sp{m-l) 

cp(m) = cp(2) * cp(m-l) - sp(2) * sp(m-l) 
enddo 

aor = 6371.2/rkm 
ar = aor * aor * aor 
p(2,l) = ct 
dp(2,l) = -St 
p(2,2) = St 
dp(2,2) = ct 

br = - (ar+ar)* (g(2,l) *p (2 , 1) +p (2 , 2) * (g (2 , 2) *cp (2) +g (1 , 2) *sp (2) ) ) 
bt = ar * (g(2,l)*dp(2,l)+dp(2,2)*{g(2,2)*cp(2)+g(l,2)*sp(2))) 
bp = ar * {g(l,2) * cp(2) - g(2,2) * sp(2)) * p(2,2) 

do n = 3 , nmax 
ar = aor*ar 
do m = l,n 

if(m.ne.n) then 

p(n,m) = ct * p{n-l,m) - const(n,m) * p(n-2,m) 

dp(n,m) = ct * dp{n-l,m) -st*p(n-l,m) -const (n,m) *dp{n-2,m) 



endif 
par = p(n,m) * ar 
if(m.ne.l) then 

temp = g(n,m) * cp (m) + g{m-l,n) * sp (m) 
bp = bp - (g(n,m) *sp{m) -g(m-l,n) *cp (m) ) * fm(m) * par 
else 

temp = g(n,m) 
endif 

br = br - temp * fn(n) * par 
bt = bt + temp * dp(n,m) * ar 

enddo 
enddo 

bp = bp/st/lOOOOO. 
br = br/100000. 
bt = bt/100000. . 




*****★★★* 



else 
p{n,n) 
dp(n,n) 



St * p(n-l,n-l) 
= St * dp(n-l,n-l) + ct * p(n-l,n-l) 




IF {abs(bp) .LT. 1.0E18 .AND. abs (br) .LT. 1.0E18 .AND. 
& abs(bt) .LT. 1.0E18) THEN 

b = sqrt (br*br + bt*bt + bp*bp ) 
ELSE 

b =: 1.0E18 
ENDIF 



return 
end 

subroutine cannla (B, xi, vl) 

implicit none 
save 



real*8 B, constem, gg, vl, xi, xx 
c compute 1 

C *********** *********************************************** 

C Equations Containing Constant Mag Moment Will Be Commented 
C Out And Rewritten With New Mag Moment Calculated In Stmag 
C Subrout ine 3/15/91 

C ************************************************** ******** 

common /gmagmo/ constem 

if( xi-l.Od-36 .le. 0.) then 

vl= (constem/B) ** (1 . /3 . ) 

return 
end if 

xx = 3.0 * dlog(xi) 

XX = XX + dlog (B/constem) 

if (xx+22. ;le. 0.) then 

gg = .333338*xx-*-. 30062102 

go to 7 
endif 

if{xx+3. .le. 0.) then 

gg=( (((({( (-8.1537735d-14*xx+8.3232531d-13)*xx+1.0066362d-9)*xx+ 

1 8 . 1048663d-8) *xx+3 . 2916354d-6) *xx+8 . 2711096d-5) *xx 

2 +1. 371466 7d- 3) *xx+. 015017245) *xx+ . 43432642 ) *xx+ . 6233 7691 
go to 7 

endif 



if{xx-3. .le. 0.0) then 

gg= ({((((( (2 . 6047023d-10*xx+2 . 3028767d-9) *xx-2 . 1997983d-8) * 

1 5.3 977642d-7) *xx-3 . 3408822d-6) *xx+3 . 83 79917d-5) *xx + 

2 1.1784234d-3) *xx+1.4492441d-2) *xx+. 43352788) *xx+.6228644dO 
go to 7 

endif 

if(xx-ll.7 .le. 0.) then 

gg= (({(((( (6 . 3271665d-10*xx-3. 958306d-8) *xx+9 . 9766148d- 07) *: 

1 1.2531932d-5) *xx+7 . 9451313d-5) *xx-3 . 2077032d-4 ) *xx + 

2 2.1680398d-3) *xx+l . 2817956d-2 ) *xx+ . 43510529 ) *xx+ . 6222355d0 
go to 7 

endif 

if(xx-23. .le. 0) then 

gg= { ( { { (2 . 8212095d-8*xx-3 . 8049276d-6) *xx+2 . 170224d-4) *xx - 
1 6.73103 39d-3) *xx+ . 12 038224) *xx- . 18461796 ) *xx+2 . 0007187 
else 



endif 

7 vl = (((1.0+dexp (gg) ) ♦constem) /B) ** (1. /3 . ) 

end compute 1 

return 

end 



subroutine intega(arc, beg, bend, b, jep, eco, fi) 



IMPLICIT REAL*8 (A-H,0-Z) , INTEGER (I-N) 
implicit none 
save 

real*8 a, arc, argl, asum, b, bb, beg, bend, c, dn, eco, fi 
real*8 t, tb, te, x2, x3 

integer*4 i, kk,jep 

dimension arc (200) , beg (200) , bend (200) ,b(200) , eco (200) 
dimension arc(l) ,beg(l) ,bend(l) ,b(l) ,eco(l) 

kk = jep 

if (kk .gt. 4) go to 20 

if (kk .eq. 4) kk = kk-1 

a ,= b(kk-l)/b{2) 

x2 = b(kk)/b{2) 

x3 = b(kk+l)/b(2) 

asum = arc{kk) + arc (kk+1) 

dn = arc (kk) *arc (kk+1) *asum 

bb = (-a*arc (kk+1) * (arc (kk) +asum) +x2*asum**2-x3*arc (kk) **2) /dn 

c = (a*arc(kk+l) - x2 * asum + x3 * arc (kk) ) /dn 

fi =.157079632d+01 * (1 . 0-a+bb*bb/ (4 . 0*c) ) / dsqrt (dabs (c) ) 

return 

20 t = dsqrt (1.0d0-bend(2) ,/b{2) ) 

fi = (2.0*t-dlog((1.0+t)/(1.0-t)))/eco(2) 
if (b(2) -bend(kk) .gt. 0.) kk=kk+l 
t = dsqrt (dabs (l.O-beg(kk) /b (2) ) ) 
fi = fi- (2.0*t-dlog( (1.0+t)/(1.0-t) ) )/eco(kk) 
kk = kk - 1 
22 do i = 3, kk 

argl = 1. - bend{i)/b(2) 
if (argl .le. 0.) then 

te = l.d-5 
else 

te = dsqrt (argl) 
endif 

argl = 1. - beg(i)/b(2) 
if (argl .gt. 0.) then 

tb = dsqrt (argl) 
else 

tb = l.d-5 
endif 

if (dabs(eco(i) ) -2.d-5 .le. 0.) then 

fi = fi + ((te+tb)*(arc(i)+arc(i+l)))/4, 
else 

fi = fi+(2.*(te-tb)-dlog({l.+te)*(l.-tb)/((l.-te)*(l.+tb)))) 
1 /eco(i) 
endif 
enddo 




30 return 
end 




subroutine invara (model , tm, flat, flong, alt, err, bb, fn) 

C **** Note, Error In L Is Typically Less Than 10.*Err*L (Percent) 
C **** Flat=Latitude In Degrees , Flong Longitude In Degrees 
C **** Alt=:Altitude=Distance From Surface Of Earth In Kilometers 
c IMPLICIT REAL*8(A-H,0-Z) , INTEGER (I-N) 

implicit none 

save 

real*4 Tm 

real*8 alt, arc, asum, b, bb, bco, beg, bend, blog, ceo, dclt 

real*8 dco, dn, dx, eco, err, fl, flint 

real*8 flat, flong, fn, rl, r2, r3, sa, sc, v, vp, vn 

integer*4 i, j, jep, jup, model 

dimension V (3,3) , b(200) , arc(200), vn(3) , vp(3) , beg{200), 
1 bend(200), blog(200), eco(200), rl(3), r2(3), r3 (3) 

v(l,2) = alt/6371.2 
v(2,2) = (90. -flat) /57. 2957795 
v(3,2) = flong/57. 2957795 
□ arc(l) = 0. 

^ arc(2) = (1.0+v{l,2)) * sqrt (err) * 0.3 

g dclt = 1.5708-0.2007 * dcos(v(3,2) + 1.239) 

n if {v(2,2) .gt. dclt) arc(2) = -arc(2) 

1^ call starta(rl, r2, r3, b, arc, v, model, tm) 

f==i do i = 1, 3 

[H vp{i) = v(i,2) 

[7 vn (i) = v(i, 3) 

enddo 

call linesa(rl, r2, r3, b, arc, err, j, vp, vn, model, tm) 
Ui if (j -ge. 200) then 

go to 18 
^ endif 

jup = j . 
"""-^ do j =1, jup 

arc(j) = dabs (arc (j) ) 
blog(j) = dlog(b(j)) 
enddo 

jep = jup-1 
do j =2, jep 

asum = arc(j) + arc(j+l) 

dx = blog(j-l) - blog(j) 

dn = asum * arc(j) * arc(j+l) 

bco = ((blog(j-l) - blog(j+l)) * arc{j)**2 -dx *asum**2)/dn 
ceo = (dx * arc(j+l) - (blog(j) - blog(j+i)) * arc{j)) / dn 
sa = .75 * arc(j) 
sc = sa + .25 * asum 
dco = blog(j-l) - ceo * sa ♦ sc • 
eco(j) = bco + ceo * (sa + sc) 
fc>eg(j) = dexp(dco+eco(j) * .5 * arc(j)) 
bend(j) = dexp (deo+eco ( j ) * .5 * (asum+arc ( j ) ) ) 
enddo 

t>eg(jup) = bend (jep) 
bend (jup) = b(jup) 

eco{jup) = (2.0/arc(jup) ) * dlog (bend (jup) /beg (jup) ) 



call intega{arc^^g, bend, b, jep, eco, flint) 
call carmla (b(^n flint, fl) 
18 bb = b(2) 
fn = fl 
return 
end 

subroutine linesa(rl, r2, r3, b, arc, err, j, vp, vn, model, tm) 

c implicit real*8 (a-h, o-z) , integer (i-n) 

implicit none 
save 

real* 4 tm 



real*8 al, a2, a3, aa, aab, ad, am, ao6, arc, arc j , asum, b 
real*8 bb, bd, bp, br, bt, cc, cd, cop, cot, ere, dd, dn, err 
real*8 prel, pre2, pre3, qrt, rl, r2, r3 

real*8 ra, rbar, rkm, rt, sip, sit, sna, ssq, vp, vn, x 
integer*4 i, ilp, is, j, model 

dimension b (200) , arc{200), rl{3), r2(3), r3(3), vn(3), vp(3), ra(3) 
dimension b(l), arc(l) ! subroutine arguments 
dimension rl (3) , r2(3), r3 (3) , vn(3), vp(3), ra(3) 
ere = 0.25 

if (err .It. 0.15625) ere = (err**0 . 333333333 ) 

a3 = arc (3) 

aab = dabs(a3) 

sna = a3/aab 

al = arc(l) 

a2 = arc (2) 

ao6 = a3*a3/6.0 

j = 3 

ilp = 1 

is = 1 

GO TO 87 

66 is = 1 
j = j+1 

ao6 = a3 * a3/6.0 
arcj = al + a2 + a3 
ad = (asum+al)/aa 
bd = asum/bb 
cd = al/cc 
36 do i = 1, 3 

dd = rl(i)/aa-r2{i)/bb+r3(i)/cc 

if (is .eq. 1) then 

rt = rl(i) - (ad*rl(i) -bd*r2 (i) +cd*r3 (i) -dd*arcj) * arcj 
ra(i) = rl(i) 
rl(i) = r2(i) 
r2(i) = r3(i) 
r3(i) = rt 
vp(i) = vn{i) 
endif 

rbar = (r2(i) + r3(i))/2. - dd * ao6 
vn(i) = vp{i) + a3 * rbar 
enddo 



87 if (vn{2) 



.It. 0.) vn(2) = -vn(2) 



77 if (vn(2) . le . -^■^1592653 ) go to 78 

vn(2) = 6.283185307 - vn(2) 
go to 77 

78 if|vn(3) .ge. 0.) go to 81 
vn(3) =r vn(3) + 6.283185307 
go to 78 

81 if(vn(3) .le. 6.283185307) go to 82 

vn{3) = vn(3) - 6.283185307 
go to 81 

82 go to (9, 10) , is 

9 sit = dabs (dsin{vn(2) ) ) 
prel = vn(l) 
pre2 = prel * vn{2) 
pre3 = prel * sit * vn(3) 
100 rkm = vn(l) * 6371.2 

IF (rkm .It. 100.0) rkm=100.0 

ssq = sit * sit 
cot = dcos (vn (2) ) 
sip = dsin(vn (3) ) 
cop = dco&(vn(3) ) 
call allmag (model, tm, rkm, sit, cot, sip, cop, br, bt, bp, b(j)) 

Added error checking on b(j), 11-24-97. 

IF (b(j) .EQ. 0.0) b(j) = l.OE-10 iavoid underflows, 11-24-97 

r3(l) = br/b(j) 

dn = b(j) * vn(l) 

r3 (2) = bt/dn 

r3(3) = bp/(dn*sit) 
asum = a3+a2 
aa = asum*a2 
bb = a3*a2 
cc = asum*a3 
is = 2 
go to 36 

10 sit = dabs(dsin(vn(2) ) ) 

b(j) = b(j) * ( (prel/vn(l) )**3) 

qrt = 0.5d0 ♦ dabs (r3 (1) ) / (0 . IdO+dabs (r3 (2) *vn (1) ) ) 

X = (<iabs(vn(l)-prel)+qrt*dabs(vn{l)*vn(2)-pre2)+dabs(vn(l)*sit* 
1 vn{3) -pre3) ) / (aab*err*dsqrt (1 . +qrt*qrt) ) 
go to (90, 93, 90) , ilp 
93 if (x - 3,3) 90, 89, 89 
89 a3 = a3 ♦ 0.2 * (8 . 0+x) / (0 . 8+x) 
j = j - 1 
ilp = 3 
asum = a2+al 
aa = asum * al 
bb = a2 * al 
cc = asum * a2 
do i = 1, 3 

vn(i) = vp(i) 

r3(i) = r2{i) 

r2(i) = rl(i) 

rl(i) = ra(i) 
enddo 
go to 73 





hi 



90 if (j .gt. 200) go to 60 
al = a2 

if{b(j)-b(2) .gt. 0 ) go to 60 
CF? if(b(j)-b(2) .gt. 0 .OR. b(j) .EQ. 0.0) go to 60 !changed 11-24-97, 

ilp = 2 
a2 = a3 

a3 = a3 * .2 ♦ (8 . +x) / ( . 8+x) 

am = (2.-r3(2) ♦ vn{l)) * vn(l) * ere 

if (dabs (a3) -am .gt. 0.) a3 = sna * am 

if(sna * r3(l)+.5 .gt. 0.) go to 73 

am = -.5 * sna * vn(l)/r3(l) 
if (dabs {a3) -am .gt. 0) a3 = sna * am 
73 arc(j+l) = a3 
aab = dabs(a3) 
go to 66 

60 return 
end 

c** ****************************** **************** 

subroutine starta{rl, r2, r3, b, arc, v, model, tm) 

Qit-k-k ******* *i 

c implicit real*8 (a-h, o-z) , integer (i-n) 

implicit none 
save 

real*8 aer, arc, b, bp, br, bt, cop, cot, dn 
real*8 oer, sip, sit, ssq, rl, r2, r3 , rkm, v 

real*4 tm 

integer*4 i , is , model 
c dimension b{l) , arc(l), v{3, 3), rl(3), r2(3), r3(3) 

dimension b{l) , arc(l), v(3, 3), rl(l), r2 (1) , r3(l) ! arguments 

sit = dabs(dsin(v(2,2) ) ) 
aer = v(l,2) 
ssq = sit * sit 

oer = (6356 . 912+ssq * (21 . 3677+ . 108 * ssq))/6371.2 
v(l,2) = aer + oer 
10 if (v(3,2) .ge. 0. ) go to 12 
v(3,2) = v(3,2) + 6.283185307 
go to 10 



12 rkm = v{l,2) * 6371.2 
c if (model, eq. 6) rkm = rkm+14 . 288-ssq * (21 . 3677+ . 108 * ssq) ! CHECK ORIG MODEL NO;'S 

cot = dcos (v(2,2) ) 
sip = dsin{v{3,2) ) 
cop = dcos (v (3, 2) ) 

call allmag (model, tm, rkm, sit, cot, sip, cop, br, bt, bp, b(2)) 
r2(l) = br/b(2) 
dn = b(2) * v(l,2) 
r2 (2) = bt/dn 
r2(3) = bp/(dn * sit) 
is = 0 
1 do i = 1, 3 

v(i,l) = v{i,2) -arc(2) * r2(i) 
enddo 

sit = dabs (dsin(v(2, 1) ) ) 
3 rkm = v(l,l) * 6371.2 



ssq sit^^^ 

if (model. eq. 6) rkm = rkm+14 . 288-ssq * (21 . 3677+ . 108 * ssq) 
cot = dcos (v(2, 1) ) 
sip = dsin(v(3, 1) ) 
cop = dcos (v(3, 1) ) 

call allmag (model, tm, rkm, sit, cot, sip, cop, br, bt, bp, b(l)) 
if ( b(l)-b(2) .ge. 0.) go to 5 
arc (2) = -arc (2) 
go to 1 

5 rl(l) = br/b(l) 
arc (3) = arc (2) 
dn = b(l) ♦ v(l,l) 
rl(2) = bt/dn 
rl(3) = bp/(dn * sit) 
do i=l, 3 

v(i,l) = v(i,2)-arc(2) * (rl (i) +r2 (i) ) /2 . 
enddo 

sit = dabs (dsin(v(2, 1) ) ) 
is = is+l 
go to (3 , 7) , is 
if (is .eq. 1) go to 3 
7 do i - 1, 3 
do i = 1, 3 

v(i,3) = v(i,2)+arc(3) * ((1.5) * r2(i)-.5 * rl(i)) 
enddo 
return 
end 

subroutine stmag (model, tm) 
******************************************************************** 

Constant Mag Moment Replaced With Calculated Mag Moment, 
Using Geomagnetic Field Expansion Coef f iecients - 3/15/91 

Inputs model choice of 2 models - see below 

rkm geocentric distance in kilometers 

tm time in years for desired field 

st,ct sin + cos of geocentric colatitude 

sph,cph sin + cos of east longitude 
Outputs br,bt,bp geocentric field components in gauss 

b field magnitude in gauss 

IMPLICIT REAL*8 (A-H,0-Z) 
implicit none 
save 

real*8 const, constem, em, fl, f2, f3, fm, fn, g 
real*8 rad, t, tO 

real*4 tm, tmold 

integer*4 jj, k, 1, m, modold, n, nmax, nmx, model 
common /gmagmo/ constem 

integer*4 gl (13 , 13) , gtl (13 , 13) , gttl (13 , 13) , g2(13,13), gt2(13,13), 
1 gtt2(13,13) , lg(l3,13,2), Igt ( 13 , 13 , 2) , Igtt (13 , 13 , 2) 

real*4 gg(13,13,2), ggt (13 , 13 , 2) , ggtt (13 , 13 , 2) , shmit(13,13) 



equivalence (gl,gg,lg), (gtl, ggt, Igt) , (gttl,ggtt , Igtt) , 
2 (g2,lg(l,l,2) ) , (gt2 , Igt (1, 1, 2) ) , {gtt2 , Igtt (1 , 1 , 2 ) ) 



character*32 label (2) 



dimension t0(2), nmx(2) 

common/magcof/ g{i4,14), fn(14), fm(l4) , const (14 , 14) , nmax 

data label (1)/'IGRF 1965.0 80-TERM 10/68 
data label (2) /'HURWITZ US C+GS 168-TERM 1970 



data t0/l965.d+00,1970.d+00/ 
data nmx/9,13/ 



***** 



Gl,Gtl Igrf 1965.0 80-Term 10/68 Epoch 1965 

data gl / l, -30339,-1654,1297,958,-223,47,71,10,4*0,5758,-2123 
A 2994,-2036,805,357,60.-54,9.4*0,-2006,130,1567,1289,492 246 4 0 
B -3,4*0,-403,242.-176,843,-392,-26.-229,12,-12,4*0,149,-280,8,-265 
C ,256,-161,3,-25,-4,4*0,16,125,-123,-107.77,-51,-4,-9,7 4*0 -14 

D 106.68.-32,-10,-13.-112,13,-5,4*0,-57,-27,-8,9,23,-19,-17,-2,12, 
E 4*0,3,-13,5,-17,4,22,-3,-16,6,56*0/ 

data gtl / 10, 153,-244,2,-7,19,-1,-5,1,4*0,-23,87,3,-108,2,11,-3 
F -3,4,4*0,-118,-167,-16,7,-30,29,11,-7,6,4*0,42,7,-77,-38,-1,6,19! 
G -5,5*0,-1,16,29,-42,-21,0,-4,3,5*0,23,17,-24,8,-3,13,-4,0,-1,4*0, 

H-9, -4, 20, -11, 1,9, -2, -2, 3, 4*0, -11, 3, 4, 2, 4, 2, 3, -6, -3, 4*0, 1,-2, -3, -2, 
I -3,-4,-3,-3,-5,56*0/ 

data gttl /l, 168*0/ 

***** G2,GT2 Hurwitz Us Coast + Geodetic S. 168-Term Epoch 1970 
data 92/10,-302059,-17917,12899,9475,-2145,460,734,121,107,-39 16* 
A -4,57446,-20664,29971,-20708,8009,3595,651,-546,77,57,-26,-31 3o' 
B -20582,430,16086,12760,4579,2490,95,46,-32,23,7,-36,5,-3699,2456' 
C -1880,8334,-3960, -290, -2188,175,-124,-110, -19 , 37 , -3 , 1617, -2758 ' 
D 185, -2788,2436,-1669,20, -210, -44, 131, -15, -3, -13, 157, 1420, -1310,' 
E -911,808,-582,-22,-32,45,33,74,-6,4,-171,1146,625,-323,-78,38, 
F -1125,143,34,2,46,-8,-14,-666,-265,-34,81,209,-240,-186,41,125 
G 15,6,1,-12,121,-160,22,-176,46,189,-46,-187,94,9,-8,2,-12 -174 ' 
H 163,14,-27,-32,80,137,-4,-14,-4,22,-24,-1,27,19,0,35,-45,22,-31 
I 56,-1,-63,14,4,10,-2,26,-26,-9,21,-1,18,-14,-28,-17,-14,6,-4,-3 
J 4,9,-1,-10,26,-32,13,-6,-19,7,19,12/ 

data gt2/l0, 231, -244, -19, -7, 12, -7, 0,3, 4*0, -46, 112, -1,-90, -6, 7, 6, 
K -3,3,4*0,-104,-166,40,-20,-36,12,14,3,4,4*0,72,21,-52,-54,-11,0, 
L 17,6,1,4*0,22,-5,14,-24,-23,-15,6,3,-1,4*0,1,25,-14,9,1.11,-3,2, 

M -3,4*0,-5,11,2,-3,7,22,-5.1,9,4*0,-17,-3,7,1,-2,-3,-2.-1.-2.4*0, 
N 2,-6,-3.-4,1,-2,-2,-1,6,56*0/ 
data gtt2 /l, 168*0/ 

data shmit{l,l) / o.O /, tmold / -100./ 
parameter (rad = 57.29577636718750) 

***** Beg in Program 

if (model .It. 1 .or. model .gt. 2) stop 'stmagl' 

if (shmitd.l) .eq.-l.) go to 8 ! already initialized 

do n = 1, 14 
fn(n) = n 
do m = 1, 14 
fm(m) = m-1 

const{n,m) = float ( (n-2) **2- (m-l) **2) / ( (2*n-3) * (2*n-5) ) 



enddo 
enddo 




C ***** Initialize * Once Only, First Time Subroutine Is Called 
shmit{l,i) = -1. 
do n = 2, 13 

shmit(n,l) = (2 * n-3) ♦ shmit (n-l , l) / (n-l) 

jj=2 

do m = 2, n 

shmit{n,m) = shmit (n, m-1) *sqrt (float ( (n-m+l) * jj)/(n+m-2)) 
shmit (m-l,n) = shmit (n,m) 
jj = 1 
enddo 
enddo 



do k = 1, 2 

fl = lg(l,l,k) 
f2 = lgt(l,l,k) 
f3 = lgtt(l,l,k) 
nmax = nmx(k) 
1 = 0 

do n = 1, nmax 
do m = 1, nmax 

gg(n,m,k) = lg(n,m,k) * shmit (n, m) /fl 
ggt(n,m,k) = lgt{n,m,k) * shmit (n, m) /f 2 
ggtt(n,m,k) = lgtt(n,m,k) * shmit (n, m) /f 3 
enddo 1 m 
enddo ! n 
enddo ! k 

8 if (model. eq.modold) return 



2 C ***** NOTE WRITE STATEMENT - NEW MODEL OR NEW TIME 
type 9, model, label ( model) , tm 
9 formate model used is number i2 , 2x, a32 , ' for tm =',f9.3/) 

modold = model 
tmold - tm 
nmax = nmx (model) 
t = tm- to (model) 
do n = 1, nmax 
do m = 1, nmax 

g{n,m) = gg (n, m, model) +t * (ggt (n, m, model) +ggtt (n, m, model) *t) 
enddo 
enddo 

em = sqrt (g(l,2) **2 + g(2,2)**2 + g(2,l)**2) 
constem = em/100000.0 
return 
end 



C^J|sEU_RATE {NBITS , SEU_RATE , DAY_rI|||^ 



SUBROUTINE 

& PERSECOND, PERDAY) 

IMPLICIT NONE 

REAL*4 NBITS , SEU^RATE , DAY_RATE , PERSECOND , PERDAY 

C 

C INPUTS : 

C NBITS = number of bits per device 

C SEU_RATE = calculated SEU rate (in upsets/bit/second) 

C OUTPUTS : 

C PERSECOND = upsets/device/second 

C PERDAY = upsets/device/day 

C DAY_RATE = upsets/bit/day 



PERSECOND=NBITS*SEU_RATE 
PERDAY=PERSECOND*24 . 0*3600 . 
DAY RATE=SEU RATE*24 . 0*3600 . 



RETURN 
END 



SUBROUTINE 




iI2E_STRING (STRING, ILONG) 



Re-writes an input character string STRING of length ILONG 



IMPLICIT NONE 
CHARACTER STRING 
INTEGER* 4 ILONG, I 
IF (ILONG. GE.l) THEN 
DO 100 1=1, ILONG 

IF (ICHAR (string (i ; i) ) .GE. 97) THEN 

string (i:i) = CHAR (ICHAR (string (i : i) ) - 32) 
ENDIF 
100 CONTINUE 



into all capitals. 



ENDIF 



RETURN 
END 



SUBROUTINE C] 



:REME96_VERSI0N (FILENAME, IVER 



m 



c 
c 
c 



Examines first line of input file, to get version number 



IMPLICIT NONE 

CHARACTER*80 FILENAME, I LINE 

CHARACTER*3 VERSIONLABEL 

INTEGER* 4 NCHAR, IVER, STAT, CREME96_OPEN 

INTEGER*4 FILENO 

DATA FILENO/4/ 

C Modified 7/29/96: Version 1.01 

c OPEN(UNIT=FILENO,FILE='USER:' //FILENAME, STATUS='OLD' , 

C & READONLY , SHARED ) 

Stat = creme96_open(filename, 'user' , fileno, 'old' ) 

READ (FILENO, 1) ILINE 
1 FORMAT (A80) 

NCHAR=3 

VERS IONLABEL= ILINE (76:78) 

IF (VERSIONLABEL. EQ. ' ') THEN 
IVER=0 

ELSE 

read (versionlabel , ' (i3) ' ) iver 
ENDIF 



CLOSE (FILENO) 

RETURN 

END 



SUBROUTINE 



Cli^^FILE (IFILETYPE, FILENAME, lACC^^ 



Subroutine for checking existence and acceptability of specified 
input file. 

IMPLICIT NONE 

INTEGER*4 MHMAX, NLINES , MAXFILETYPE 
PARAMETER (MAXFILETyPE=8 ) 
CHARACTER* 80 ILINES , TEMPLINE 
PARAMETER (MHMAX=20) 
DIMENSION ILINES (MHMAX) 

INTEGER*4 IFILETYPE, JFILETYPE, J, lACCEPT, lANSWER, NHMAX, IHMAX 
DIMENSION IHMAX (MAXFILETYPE) 
DATA IHMAX/3,3,10,15,20,20,4, 1/ 
CHARACTER* 80 FILENAME 

LOGICAL lEXIST, FILE_CHECKS, CREME96_INQUIRE 

INTEGER* 4 lERR 
DATA IERR/0/ 



IACCEPT=0 

CALL GET_CHECK_CONTROL(FILE_CHECKS) 
IF (.not. FILE_CHECKS) RETURN 

First, see if specified input file exists: 

INQUIRE (FILE=' USER: ' //FILENAME, EXIST=IEXIST) 
iexist = creme96_inquire (filename, 'user' ) 
IF (.NOT. IEXIST) THEN 
WRITE (6, 999) 

FORMATdX,' This file was not found in USER area.', 
& ' Please try again.') 

CALL SHOW_DIRECTORY(IFILETYPE) 
IACCEPT=-1 
RETURN 
ENDIF 

IF (IFILETYPE.EQ.O) RETURN 

Now see if file has correct type: 

CALL CHECK_FILE_TYPE ( FILENAME , JFILETYPE) 

IF (JFILETYPE.GT.O) THEN 

IF (IFILETYPE.EQ.l) THEN 

IF ( JFILETYPE. NE.l) THEN 
WRITE(6, 9001) 

FORMATdx,' This file does not contain a trapped', 
& ' proton flux. Please try again.') 

CALL SHOW_DIRECTORY(IFILETYPE) 
IACCEPT=-1 
ENDIF 

ELSEIF {IFILETYPE.EQ.2) THEN 
IF ( JFILETYPE. NE. 2) THEN 
WRITE (6, 9002) 

FORMATdx,' This file does not contain a geomagnetic', 
& ' transmission function .',/, ix, ' Please try again:') 

CALL SHOW_DIRECTORY ( IFILETYPE) 
IACCEPT=-1 
ENDIF 

ELSEIF ( IFILETYPE. EQ. 3 .or. IFILETYPE . EQ . 4 ) THEN 
IF ( JFILETYPE. NE. 3 .and. JFILETYPE . NE . 4 



.NE.l) THEN 



WRITE(6, 9003) 

^003 FORMATdx,' This file does not contain particle', 

& ' fluxes. Please try again.') 

CALL SHOW_DIRECTORY(IFILETyPE) 
IACCEPT=-1 
ENDIF 

ELSEIF (IFILETYPE.EQ.5) THEN 
IF (JFILETYPE.NE. 5) THEN 
WRITE (6, 9005) 

9005 FORMATdx,' This file does not contain an integral', 
& ' LET spectrum. Please try again.') 

CALL SHOW_DIRECTORy ( IFILETYPE) 
IACCEPT=-1 
ENDIF 

ELSEIF ( IFILETYPE. EQ. 6) THEN 
IF (JFILETYPE.NE. 6) THEN 
WRITE (6, 9006) 

9006 FORMATdx,' This file does not contain a differential' 
& ' LET spectrum. Please try again.') 

CALL SHOW_DIRECTORY( IFILETYPE) 
IACCEPT=-1 
ENDIF 

ELSEIF (IFILETYPE.EQ. 7) THEN 

IF (JFILETYPE.NE.?) THEN 
WRITE (6, 9007) 

9007 FORMATdx,' This file does not contain a shielding', 
& ' distribution prepared by the CREME96 software.', 

& /, ' Please try again.') 

CALL SHOW_DIRECTORY (IFILETYPE) 
IACCEPT=-1 
ENDIF 

ELSEIF (IFILETYPE.EQ. 8) THEN 

IF (JFILETYPE.NE. 0 .and. JFILETYPE . NE . 8 ) THEN 
WRITE(6, 9008) 

9008 FORMATdx,' This file does not contain a', 
& ' cross-section table.', 

& /,' Please try again.') 

CALL SHOW_DIRECTORY (IFILETYPE) 
IACCEPT=-1 
ENDIF 

ENDIF 

IF (lACCEPT.LE. -1) RETURN 
ENDIF 



IF { IFILETYPE. GT.O .and. IFILETYPE . LE .MAXFILETYPE) THEN 
NHMAX= IHMAX ( I FILETYPE ) 

CALL UNLOAD_HEADERS (FILENAME , NHMAX, ILINES , NLINES) 
DO 100 J=l, NLINES 

TEMPLINE= ILINES (J) 

IF (TEMPLINE(2:2) .EQ. '%') WRITE (6, 997) TEMPLINE 
997 FORMAT (A80) 

100 CONTINUE 
ENDIF 



101 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 996) 

996 FORMATdx,' Is this the input file you want here? 0=no, l=yes' ) 
READ(*, *,ERR=101, IOSTAT=IERR) lANSWER 



IF (lANSWER.^^) THEN 
WRITE {6, 995) 
995 FORMATdx, ' Please try again.') 

CALL SHOW_DIRECTORY ( I FILETYPE ) 
IACCEPT=-1 
ENDIF 

RETURN 
END 
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PROGRAM CHE<3^^LE_DRIVER 

C 

C stand-alone version of the CHECK_FILE routine, primarily written 

C for interface to the WWW version of CREME96 . 

C 

C In response to questions, USER supplies the following information 

C IFILETYPE: indicates desired type of file (l=.trp, etc.) 

C FILENAME: filename (without directory name appended). 

C 

C Outputs from the program which are to be subsequently displayed by 

C the WWW interface are prefaced with preface "**") 

C 

IMPLICIT NONE 

INTEGER* 4 IFILETYPE , JFILETYPE 
CHARACTER* 80 FILENAME 
LOGICAL IEXIST,CREME96_INQUIRE 
INTEGER* 4 IERR,K 
CHARACTER*30 DESCRIP 
DIMENSION DESCRIP (11) 

DATA DESCRIP/' a trapped proton flux', 



& ' a geomag transmission fen' , 

& ' external particle fluxes', 

& ' internal particle fluxes' , 

& ' an integral LET spectrum' , 

& 'a differential LET spectrum' , 

& ' a shielding distribution' , ► 

& ' a cross-section table', 

& ' a PUP-SEU report', 

& ' a HUP-SEU report', 

t 'a dose report'/ 



INTEGER*4 NHMAX, LINEMAX 
PARAMETER (NHMAX:=30) 
CHARACTER* 80 HEADER_LINE 
DIMENSION HEADER_LINE (NHMAX) 
CHARACTER*80 ILINE, ILINEOUT 




Get inputs from user: 

101 CONTINUE 
WRITE (6, 1000) 

1000 FORMAT (' Specified desired filetype: ', 

& /,' 1=.TR*; 2=.GT*; 3=.FLX; 4=.TFX; 5=.LET; 6=.DLT;', 

& ' 7=.SHD; 8=.XSD;', 

& /,' 9=.PUP; 10=. HUP, 11=.DSE') 

READ (* , * , ERR=101 , IOSTAT=IERR) IFILETYPE 

102 CONTINUE 

IF (IFILETYPE.lt. 1 .or. IFILETYPE.GT.il) THEN 
WRITE (6, 1005) IFILETYPE 
1005 FORMAT (ix, 'ERROR: IFILETYPE = ',18,' not defined. Try again.') 

STOP 
ENDIF 

WRITE (6, 1100) 
1100 FORMAT (' Enter FILENAME: ') 

READ (*, 105, ERR=102, IOSTAT=IERR) FILENAME 
105 FORMAT (A80) 



Now begin analysis of file : 



^^^ified input file exists: 



C First, see if 

C INQUIRE (FILE=:' USER :' //FILENAME, EXIST=IEXIST) 

iexist = creme96_inquire (filename, 'user' ) 

IF (.NOT. IEXIST) THEN 

WRITE (6, 9101) FILENAME (1:78) 

9101 FORMAT (Ix, '*♦' ,A78, 

% /,lx,'**not found in USER area. Try again.') 

STOP 

ELSE 

WRITE (6, 9102) FILENAME (1 : 78 ) 

9102 FORMAT (Ix, '**' ,A78) 
ENDIF 

C 

C Now see if filetype matches requested type. 

IF ( I FILETYPE. EQ. 8) THEN 
WRITE (6, 9105) 

9105 FORMAT (Ix, ' **According to the extension (.xsd), this file 

% /, Ix, ' **contains a user-supplied cross-section table 

% /,lx,'**Here are the first 2 lines of the file: ') 

ELSEIF (IFILETYPE.NE.8) THEN 

CALL CHECK_FILE_TyPE (FILENAME , JF I LETYPE) 

IF (IFILETYPE.EQ. JFILETYPE) THEN 

WRITE (6, 9200) DESCRIP ( IFILETYPE) 

9200 FORMAT (Ix, ' **This file contains ', A30, ) 
ELSEIF { IFILETYPE. NE. JFILETYPE) THEN 

WRITE (6, 9201) DESCRIP ( IFILETYPE) 

9201 FORMAT (Ix, ' **This file does NOT contain' , A30 ,' . Try again 
ENDIF 

ENDIF 



: Now get header information: 

LINEMAX=0 

CALL UNLOAD_HEADERS ( FILENAME , NHMAX , HEADER_LINE , LINEMAX ) 
IF (LINEMAX. LE.O) THEN 
WRITE (6, 9301) 

9301 FORMAT (Ix, ' **No header information stored in file.') 
ELSE 

IF (IFILETYPE.NE.8) WRITE (6 , 9302 ) 

9302 FORMAT (Ix, ' **Header information stored in this file:') 
DO 9400 K=l, LINEMAX 

ILINE=HEADER_LINE (K) 
ILINEOUT=' **' //ILINE(3 :80) 
WRITE(6, 9399) ILINEOUT (1 : 80) 

9399 FORMAT (lx,A80) 

9400 CONTINUE 
ENDIF 



STOP 
END 



^^k^FILE (IFILETYPE, FILENAME, lAC^^) 



SUBROUTINE 

C 

C Subroutine for checking existence and acceptability of specified 

C input file. 

C 

IMPLICIT NONE 

INTEGER*4 MHMAX, NLINES , MAXFILETYPE 
PARAMETER (MAXFILETYPE=8 ) 
CHARACTER*80 I L INES , TEMPLING 
PARAMETER (MHMAX=20) 
DIMENSION ILINES (MHMAX) 

INTEGER*4 IFILETYPE, JFILETYPE, J, lACCEPT, lANSWER, NHMAX , IHMAX 
DIMENSION IHMAX (MAXFILETYPE) 
DATA IHMAX/2,3,10,15,20,20,4,1/ 
CHARACTER* 80 FILENAME 

LOGICAL lEXIST, NO_CHECKS , CREME96_INQUIRE 
DATA NO_CHECKS/. FALSE. / 



INTEGER*4 lERR 
DATA IERR/0/ 

C 
C 

IACCEPT=0 

IF (NO_CHECKS) RETURN 



RETURN 
END 



SUBROUTINE CHEC! 



.E_TYPE (FILENAME, IFILETYPE) 




C 



C Examines first line of input file, to check file -type code 
C 

IMPLICIT NONE 
CHARACTER* 80 FILENAME 
INTEGER*4 IVER, STAT, CREME96_OPEN 
INTEGER*4 IFILETYPE , FILENO 
DATA FILENO/4/ 

CALL CHECK_CREME96_VERS ION (FILENAME, IVER) 

IFILETYPE=0 

IF (IVER.EQ.O) RETURN 

C OPEN (UNIT=FILENO,FILE=' USER: ' //FILENAME, STATUS =' OLD' , 

C & READONLY, SHARED) 

Stat = creme96_open (filename, 'user' , fileno, 'old' ) 

READ (FILENO, 1) IFILETYPE 
1 FORMAT ( 7 8x, 12} 
CLOSE (FILENO) 



RETURN 
END 



SUBROUTINE CHEI 



[EADER_LENGTH (FILENAME , NHEADERT 



C 

c 
c 



Examines first line of input file, to get header length. 



IMPLICIT NONE 

CHARACTER*80 FILENAME , ILINE 

INTEGER*4 IVER, NHEADER, STAT, CREME96_OPEN 

INTEGER*4 FILENO 

DATA FILENO/4/ 

CALL CHECK_CREME96_VERSION (FILENAME, IVER) 

IF ( IVER . EQ . 0 . or . IVER . EQ . 101 ) NHEADER=2 

IF ( IVER. GE. 102) THEN 
c OPEN (UNIT=FILENO,FILE=' USER: ' //FILENAME , STATUS =' OLD' , 

c & READONLY, SHARED) 

Stat = creme96_open( filename, 'user' ,fileno, 'old' ) 

READ ( FILENO , * ) NHEADER 

ENDIF 



CLOSE (FILENO) 

RETURN 

END 



SUBROUTINE 



_NAME_CONFLICT ( INFILE , OUTFILR 




.CCEPT) 



Makes sure that input and output names are not identical. 
IMPLICIT NONE 

CHARACTER* 80 INFILE, OUTF I LE , TEMP IN, TEMPOUT 
INTEGER*4 I ACCEPT, I LONG 
LOGICAL FILE_CHECK 

IACCEPT=0 

CALL GET_CHECK_CONTROL(FILE_CHECK) 
IF (.not. FILE_CHECK) RETURN 

Dispose of version numbers 

ILONG= INDEX (INFILE, ' ; ' ) 
TEMPIN=INFILE 

IF (ILONG.NE.O) TEMPIN= INFILE (1 : ILONG- 1) 

TEMPOUT=OUTFILE 

ILONG= INDEX (OUTFILE, ' ; ' ) 

IF ( ILONG . NE . 0) TEMPOUT=OUTFILE ( 1 : ILONG- 1 ) 
Convert to upper case : 
ILONG=LEN (TEMPIN) 

CALL CAPITALIZE_STRING(TEMPIN, ILONG) 
ILONG=LEN (TEMPOUT) 

CALL CAPITALIZE_STRING (TEMPOUT, ILONG) 

Now see if identical: 
IF (TEMPIN.EQ. TEMPOUT) THEN 
IACCEPT=-1 

WRITE (6, 666) TEMP IN, TEMPOUT 

FORMAT dx,' INFILE = ',A69,/,lx,' OUTFILE = ',A69, 



/,lx,' ERROR: Input and Output filenames are identical. 
/,lx,' Please enter another output filename.') 



ENDIF 



RETXJRN 
END 




SUBROUTINE C^^_OUTPUT_FILE (FILENAME, lACCEPT 

C 

C Subroutine for checking existence and specified output file. 

C 

IMPLICIT NONE 
CHARACTER* 80 FILENAME 
INTEGER*4 lACCEPT, I RE PEAT 

LOGICAL lEXIST, FILE_CHECK, CREME96_INQUIRE 

C 

IACCEPT=0 

CALL GET_CHECK_CONTROL(FILE_CHECK) 
IF (.not. FILE_CHECK) RETURN 
IEXIST=. FALSE. 

C See if specified output file already exists: 

C INQUIRE (FILE=' USER: '//FILENAME, EXIST=IEXIST) 

iexist = creme96_inquire (filename, 'user' ) 

IF (IEXIST) THEN 
WRITE(6, 999) 
999 FORMATdX,' A file with this name', 

& ' already exists in your USER area.', 

& /,lx,' Do you wish to create a new file with' , 

& ' the same name? {0=no, l=yes) ' ) 

READ(*, *,ERR=101) IREPEAT 

IF ( IREPEAT. NE.l) THEN 
IACCEPT=:-1 
101 CONTINUE 

WRITE (6, 995) 

995 FORMAT (Ix,' Please give another name: ') 
ELSE 

IACCEPT=0 
WRITE (6, 996) 

996 FORMATdx,' A new file with this same name will', 
& ' be created. ' ) 

ENDIF 

ENDIF 



RETURN 
END 



SUBROUTINE d^^_RPP_DIMENSIONS (XMO , YMO , 2M0 , 
^ IPARAM, PARAMS,XSECT_FILE, 

& XM,YM,ZM) 



C 



C Routine for extracting lateral RPP dimension from cross-section 

C when the input XM,YM values are zero: 

C 

C Inputs : 

C 

C XM,YM,2M = bit dimensions (in microns) 

C IPARAM = 1,2,4, indicating cross -section model 

C 1 = Bendel 1 -parameter 

C 2 = Bendel 2 -parameter 

C 4 = Weibull 

C 5 = Critical charge (pc) 

C * 0 = table 

C PARAMS{4) = array containing cross-section parameters 

C XSECT_FILE = file containing cross-section table 

C 

C Outputs: XM,YM, ZM = revised RPP dimension 

C 

C 

C Written by: Allan J. Tylka 

C Code 7654 

C Naval Research Laboratory 

C Washington, DC 20375-5352 

C tylka@crs2 . nrl . navy . mil 

C 

C 

C 

IMPLICIT NONE 

INTEGER*4 IPARAM, NDUM, NTRY 

REAL* 4 XMO , YMO , ZMO , PARAMS , XM , YM , ZM , LETMAX , XSMAX , DELTA_XS 
CHARACTER* 80 XSECT^FILE 

DIMENSION PARAMS (4) , LETMAX (2) , XSMAX (2) 

C 

XM=XMO 
YM=YMO 
ZM=ZMO 

IF {XM.GT.l.OE-6 .and. YM . GT. 1 . OE-6) RETURN 

C 

C User has specified XM,YM=0. Must extract value from the 

C cross-section inputs: 

C 

IF (IPARAM. NE. 5) THEN 

NDUM=2 

NTRY=1 

LETMAX(l)=1.0E+5 
LETMAX (2 )=1.0E+6 
10 CONTINUE 

CALL EVALUATE_SEU_CROSS_SECTION (LETMAX, NDUM, IPARAM, PARAMS , 
^ XSECT_FILE, XSMAX) 

DELTA_XS=ABS (XSMAX (1) -XSMAX (2) ) /XSMAX (2) 

IF (DELTA_XS.GT.0.01) THEN 
WRITE (6, 9999) 
NTRY=NTRY+1 

LETMAX (1)=LETMAX(1) *10.0 



LETMAXl^iLETMAX (2) *10 . 0 

IF (NTRY.LE.IO) GOTO 10 
ENDIF 

ELSEIF (IPARAM.EQ. 5) THEN 

XSMAX ( 2 ) =PARAMS ( 2 ) 
ENDIF 

XM=SQRT(XSMAX(2) ) 
YM^XM 

IF (XM.LT.l.OE-6 .and. YM. LT . 1 . OE-6 ) THEN 
WRITE (6, 9998) XMO , YMO , XSMAX { 2 ) 

9998 FORMATC Error in HUP inputs: 

& /, ' Input lateral RPP dimensions = ',2E13.6, 

& /, ' Input limiting cross- section = ',E13.6, 

& /, ' SEU RATE = 0.0 1 ! ! ' ) 

ENDIF 

9999 FORMATC ERROR in CHECK_RPP_DIMENSIONS : Plateau not found.') 

RETURN 
END 



SUBROUTINE CHe|(J^HIELD_DISTRIBUTION (NSHIELD, UP^j^, FRACSHLDO, 
& UPATH , FRACSHLD , 

& XMEAN,XRMS, TOTAL, ERRFLAG) 

IMPLICIT NONE 

INTEGER*4 MAXSHIELD 

PARAMETER (MAXSHIELD=500) 

INTEGER*4 NSHIELD, K, INDX (MAXSHIELD) 

REAL* 4 UPATHO , FRACSHLDO , UPATH, FRACSHLD 

REAL* 4 XMEAN,XRMS, TOTAL 

INTEGER*4 ERRFLAG 

DIMENS ION UPATHO ( 1) , FRACSHLDO ( 1) , UPATH ( 1) , FRACSHLD ( 1 ) 

IF (NSHIELD. GT. MAXSHIELD) THEN 

WRITE (6, 995) NSHIELD, MAXSHIELD 
995 FORMATC® 07001 ABNORMAL TERMINATION: 

& /,lx,' ERROR in CHECK_SHIELD_DISTRIBUTION: ', 

& /,lx,' TOO MANY BINS: ',18,' > ',18,' max.', 

■ & /, Ix, ' STOP. ' ) 

STOP 
ENDIF 

C First, check normalization 
TOTAL=0 
O DO 100 K=l, NSHIELD 

Vfl TOTAL=TOTAL+FRACSHLD0 (K) 

Q 100 CONTINUE 

fy WRITE (6, 999) NSHIELD 

p 999 FORMATC No. Shielding Bins = ',14) 
WRITE (6, 998) TOTAL 
998 FORMATC Sum of shielding fractions = ',E13.6} 
ERRFLAG=0.0 

IF (ABS(TOTAL-l.O) .GT. 0.0001) THEN 
ERRFLAQ^l 
WRITE (6, 997) 

997 FORMATC Shielding distribution will be re-nomalized' , 

& ' to unit integral ' ) 

ENDIF 

XMEAN=0.0 
XRMS:=0.0 

DO 200 K=l, NSHIELD 
: Renormalize shielding fraction to unit integral; 

FRACSHLDO (K) =FRACSHLDO (K) /TOTAL 
2 Calculate mean 

XMEAN=XMEAN+UPATHO (K) *FRACSHLDO (K) 
- Calculate mean square: 

XRMS= XRMS+FRACSHLD0{K)*UPATH0{K)**2 
200 CONTINUE 

XRMS =XRMS - XMEAN* XMEAN 
IF (XRMS. LT. 0.0) XRMS=0.0 
XRMS=SQRT{XRMS) 
WRITE (6,250) XMEAN, XRMS 
250 FORMATdx, ' Mean shielding thickness = ',E13.6, 
& //Ix, ' RMS deviation = ',E13.6) 



ril 



c 
c 



Now re-order according to increasing shielding thic3chess. This 
ordering makes the transport code more efficient. 



CALL INDEXX (NSH.^^, MAXSHIELD, UPATHO , INDX) 



DO 500 K=1,NSHIELD 

UPATH(K) =UPATHO(INDX(K) ) 

FRACSHLD (K) =FRACSHLDO { INDX (K) ) 
500 CONTINUE 

RETURN 
END 



^^JJLdERS ( INFILE , NHEADER , OUTUNIT) 



SUBROUTINE C0P\1 
C 

C Reads NHEADER lines of header information from file INFILE 
C and copies to unit OUTUNIT (which has previously been opened 
C by the calling routine) . 

CHARACTER*80 INFILE, ILINE 

INTEGER*4 NHEADER, INUNIT, OUTUNIT, IVER, STAT, CREME96_OPEN 
DATA INUNIT/4/ 

IF (NHEADER. LE.O) RETURN 

CALL CHECK_CREME96__VERSION( INFILE, IVER) 

C OPEN (UNIT= INUNIT, FILE='USER: ' / /INFILE, 

C & STATUS = ' OLD ' , READONLY , SHARED ) 

Stat = creme96_open(infile, 'user' , inunit, 'old' ) 

IF ( IVER. LT. 102) THEN 

DO J=l, NHEADER 

READ (INUNIT, 999) ILINE 

WRITE (OUTUNIT, 999) ILINE 
999 FORMAT (A80) 

ENDDO 

ELSEIF ( IVER. GE. 102) THEN 
READ (INUNIT, 999) ILINE 
DO J=l, NHEADER 

READ (INUNIT, 999) ILINE 

WRITE (OUTUNIT, 999) ILINE 
ENDDO 

ENDIF 

CLOSE (INUNIT) 

RETURN 

END 



c 
c 
c 
c 
c 
c 
c 
c 
c 
c 



SUBROUTINE C 



St 
& 
& 



11 



j[6_D0SE (L, LETMIN, LETMAX, LETFL 

VERS ION_NUMBER , PROGRAM_COt)E , 
DOSE_PER_SECOND , 
ACCUMULATED DOSE) 



iDEL TYPE, 



AJT 12/1/97: 

Inputs: L = number of bins in integral LET spectrum 

LETMIN, LETMAX = lower, upper boundaries of LET (in MeV-cm2/g) 
LETFLUX = integral particle flux (m2-s-sr) **-l 
MODEL_TYPE = 1*4 label of CREME96 environment type. 

Outputs: VERSION_NUMBER: CREME96 Version Number 
PROGRAM_CODE : DOSE program code 
DOSE_PER_SECOND : Dose rate (rads/second) 

ACCUMULATED_DOSE: krad/sec or krad, depending upon model type 



IMPLICIT NONE 
INTEGER* 4 L,MAXSPEC 

REAL*4 LETMIN, LETMAX, LETFLUX, LETVAL 
DIMENSION LETFLUX (1) 
PARAMETER ( MAXS PEC= 5000) 
DIMENSION LETVAL( MAXS PEC) 

INTEGER* 4 VERS ION_NUMBER , PROGRAM_CODE , I , MODEL_TYPE 
REAL* 4 DOSE_PER_SECOND , ACCUMULATED_DOSE 
REAL*4 DRAD,STP,DELTA,FOURPI 

C 

WRITE(6, 9998) 
9998 FORMATdx,' DOSE_DRIVER calculation started.', 
& ' Please stand by.') 



DOSE_PER_SECOND=0 . 0 
ACCUMULATED DOSE=0.0 



CALL GET_CREME96_VERSION(VERSION_NUMBER) 
PROGRAM_CODE =11 

■ First evaluate corresponding LET Values 

IF (L.GT.MAXSPEC) THEN 

WRITE (6, 995) L,MAXSPEC 
995 FORMATC® 11001 ABNORMAL TERMINATION: 

& /,lx, ' ERROR in CREME96_DOSE : 

& /,lx, ' TOO MANY BINS: ',18,' > ',18,' max.', 

& /,lx,' STOP.') 

STOP 
ENDIF 



LETVAL { 1 ) =LETMIN 
LETVAL (L) =LETMAX 
DO 100 1=2, L-1 

LETVAL (I) =LETMIN* (LETMAX /LETMIN) ** (FLOAT ( I- 1) /FLOAT (L-1) ) 
100 CONTINUE 



Now do dose calculation 
DRAD=0.0 
DO 200 1=2, L 

STP=SQRT ( LETVAL ( I ) *LETVAL ( I - 1 ) ) 
DELTA=STP* (LETFLUX (I- 1) -LETFLUX (I) ) 
DRAD=DRAD+DELTA 
200 CONTINUE 



C Convert units: 
C (/m2-s-sr) * (MeV-cm2/g) to rad/sec 

C 1 rad = 6.24E7 MeV/g 



F0URPI=16 . 0*ATAN (1 . 0) 

DOSE PER SECOND=DRAD*FOURPI/6.24Ell 



C Now calculate ACCUMULATED DOSE: 

C For solar-quiet models, convert to rad/year 

IF (MODEL^TYPE.EQ.O) THEN 
C Calculate annual dose rate (krad/yr) : 

. ACCUMUIiATED_DOSE=DOSE_PER_SECOND*31557 . 6 
ELSEIF (MODEL_TYPE . EQ . 2 ) THEN 
C Worst -week accumulated dose (krad; in 180 hours) : 

ACCUMUIiATED_DOSE=DOSE_PER_SECOND*648 . 
ELS E I F ( MODEL_TYPE . EQ . 1 ) THEN 
C Worst-day accumulated dose (krad; in 18 hours) : 

ACCUMULATED_DOSE=DOSE_PER_SECOND*64 . 8 
ELSEIF (M0DEL_TYPE.EQ.3) THEN 
C Peak Solar Dose rate (krad/sec) : 

ACCUMULATED_DOSE=DOSE_PER_SECOND/1000 . 
ENDIF 



WRITE (6, 9999) 

9999 FORMATdx,' DOSE_DRIVER calculation completed. Thank you.') 

IF(MODEL_TYPE.EQ.O) WRITE {6 , 9000) DOSE_PER_SECOND, ACCUMULATED_DOSE 
IF{MODEL_TYPE.EQ.l) WRITE (6 , 9001) DOSE_PER_SECOND , ACCUMULATED_DOSE 
IF(M0DEL_TYPE.EQ.2) WRITE (6 , 9002 ) DOSE_PER_SECOND, ACCUMULATED_DOSE 
IF(M0DEL_TYPE.EQ.3) WRITE (6 , 9003 ) DOSE_PER SECOND, ACCUMULATED_DOSE 



9000 FORMAT (' Average Dose = ',1PE13.6,' rad/sec = ',1PE13.6, 
& ' krad/year') 

9001 FORMATC Worst-day average dose rate = ',1PE13.6,' rad/sec', 
& /,' Event -Accumulated Dose = ',1PE13.6, 

& ' krad in 18.0 hours.') 

9002 FORMATC Worst-week average dose rate = ',1PE13.6,' rad/sec', 
& /,' Event -Accumulated Dose = ',1PE13.6, 

& ' krad in 180.0 hours.') 

9003 FORMATC Peak SEP dose rate = ',1PE13.6,' rad/sec = ', 
& 1PE13 . 6 , ' krad/sec ' ) 



RETURN 
END 



SUBROUTINE CRE^!|^^FLUX ( IZLO, IZHI , ELOWER, EUPPER^!aR, IMODE, ITRANS, 

* GTRANSFILE,TRAPDFILE, 

* VERS ION_NUMBER , PROGRAM_CODE , 

* M,E,FLX) 

Routine for generating the CREME96 particle flxixes. 
Modified 7/2 9/96 to output version number & program code 



IMPLICIT NONE 
INTEGER* 4 MARR,NEIiM 
PARAMETER (MARR=5000 , NELM=:92 ) 
REAL*4 E,FLX 

DIMENSION E(MARR) ,FIiX(NELM,MARR) 



REAL*4 ENERGY , DE , GET_CREME96_FLUX 
INTEGER* 4 IZLO, IZHI , IMODE, ITRANS, J, K,M 
INTEGER* 4 VERSION_NUMBER, PROGRAM_CODE 
REAL*4 ELOWER,EUPPER,YEAR 
CHARACTER*80 GTRANSFILE, TRAPDFILE 



WRITE (6, 9998) 

9998 FORMATdx, ' FLUX_DRIVER calculation -started. Please stand by.') 
M=1002 

CALL GET_CREME96_VERSION(VERSION_NUMBER) 
PROGRAM_CODE=3 

Compute energies on logaritmically- spaced grid 

DE= (EUPPER/ELOWER) ** (1 . / (M-l . ) ) 

E(1)=EL0WER 

DO J=2,M-1 

E(J) =E(J-1) *DE 
END DO 
E (M) =EUPPER 

IF ( ITRANS. GT.O) CALL LOAD_GTF (GTRANSFILE) 

IF ( ITRANS. EQ. 2) CALL LOAD_TRAPPED_PROTONS (TRAPDFILE) 

IF (ITRANS. GT.O .and. IMODE. GE.l) CALL LOAD_SEP_QSTATES 



Compute fluxes for each element 

DO J=IZLO,IZHI 
DO K=1,M 

ENERGY=E(K) 

FLX (J, K) =GET_CREME96_FLUX (J, ENERGY, YEAR, IMODE, ITRANS) 
END DO 
END DO 

WRITE (6, 9999) 

9999 FORMAT (Ix,' FLUX_DRIVER calculation completed. Thank you.', 

& /,lx, ' All fluxes are in xinits of particles/m2-s-sr-MeV/nuc . ' , 

& ' vs . energy in MeV/nuc . ' , 

& /,lx,' Recommended next step:', 

& ' TRANS (RUN CREME9 6 : TRANSPORT DRIVER)') 



RETURN 
END 



Logical funct!^^creme96_inquire ( filename, pat h^^^ 

FILENAME: The non-fully specified name of the target file. 

PATH: Contains the VMS logical or DOS environment variable 

pointing to file location 

Calling example: 

STAT = creme96_inquire ( ' input . dat ' , ' creme96 ' ) 

A return value of .TRUE, indicates that the target file was 
found in the specified directory. .FALSE, otherwise. 

IMPLICIT NONE 

character*80 f ile, creme96_full_f ilename 
character* { * ) filename 
character* (*) path 
logical exist 

file = creme96_full_f ilename (filename, path) 

write (*,*)' In Incjuire... fullname: ',file 

inquire (f ile=f ile, exist=exist) 

write ( * , * ) ' Exist : ' , exist 

creme96_inquire = exist 

return 

end 



SUBROUTINE CR LETS PEC (LETMINMG, LETMAXMG, T^l^T, 
& ELOWER,EUPPER,M, IZLO, IZUP, 

& INPUT_FLUX, 

& VERSION_NUMBER, PROGRAM_CODE , IDIFSPEC, 

& LETMIN, LETMAX, L, SPECT, DIFSPEC) 

IMPLICIT NONE 

REAL* 4 LETMINMG , LETMAXMG , ELOWER , EUPPER 
REAL*4 LETMIN,LETMAX 
INTEGER*4 M, IZLO, IZUP, L 
CHARACTER* 12 TARGET 
INTEGER* 4 MARR , NELM , LARR 

PARAMETER (MARR=5000 , NELM=92 , LARR=:1002 ) 

REAL*4 INPUT_FLUX(NELM,MARR) , SPECT (LARR) , DIFSPEC (LARR) 
INTEGER*4 VERSION NUMBER, PROGRAM CODE, IDIFSPEC 



WRITE(6, 9998) 

9998 FORMATdx,' LETSPEC_DRIVER calculation started. 
& ' Please stand by.') 



CALL GET_CREME9 6_VERS ION ( VERS ION_NUMBER) 
PROGRAM_CODE=5 

C 
C 

C Prepare for ULET/LETSPEC calculation. 

C 

C Change units of LET range from /mg to /g 
LETMIN=1000 . 0* LETMINMG 
LETMAX=1000 . 0*LETMAXMG 

C 

C Specifiy number of points in integral LET spectrum 
L=LARR 

C 

C Now calculate integral LET spectrum: 

CALL ULET96 (LETMIN, LETMAX , TARGET , 
& ELOWER , EUPPER , M , I ZLO , I ZUP , 

& INPUT_FLUX , L , S PECT ) 

C 
C 
C 

C Now calculate differential LET spectrum 
IF ( IDIFSPEC. EQ.l) 
&CALL MAKE_DIFLET_SPECTRUM (LETMIN, LETMAX , L, SPECT, DIFSPEC) 

WRITE (6, 9999) 

9999 FORMATdx,' LETSPEC_DRIVER calculation completed. Thank you.', 
& /,lx,' Integral flux is in units of particles/m2-s-sr vs. LET', 
& 'in MeV-cm2/gram. ' , 

& /,lx,' Recommended next step: HUP', 
& ' (RUN CREME96 :HI_UPSET_DRIVER) ' ) 

IF (IDIFSPEC. EQ.l) WRITE (6 , 9997) 

9997 FORMATdx,' Differential LET spectrum of flux ' 
& ' (in particles/m2-s-sr- (MeV-cm2/gram) ) ' , 

& /,lx,' vs. LET (in MeV-cm2/gram) also calculated. ' ) 

RETURN 
END 



SUBROUTINE CI^^6_TRANSP0RT (INPUT_FLUX, 
& ELOWER, EUPPER,M, IZLO, IZUP, 

& IPATH, UPATHO , TARGET, SHIELDFILE, 

& VERS ION_NUMBER , PROGRAM_CODE , 

& OUTPUT_FLUX) 

C 

C This subroutine transports an input particle environment through a 

C specified thickness and type of shielding. It takes account both 

C ionization energy loss (dE/dx) as well as energy- dependent nuclear 

C fragmentation. The output is the particle enviroment (differential 

C fluxes vs. energy) inside the spacecraft, that is, 'behind' the specified 

C shielding. This routine includes many refinements over the old CREME 

C transport routine ("INSIDE") . Specifically: 

C 

C CREME96_TRANSPORT keeps track of projectile fragments; the old CREME 
C code ignored them. This routine also uses improved Silberberg, Tsao, 
C and Barghouty energy- dependent fragmentation cross -sections . Both of 
C these improvements can be important for thick shielding. 

C At present CREME 9 6_TRANS PORT only does aluminum shielding; future 

C versions will also offer transport through other shielding materials. 

C 

C CREME96_TRANSPORT is based on the "UPROP" code, as originally developed 

C by John R. Letaw of Severn Communication Corp. under contract to 

C the Gamma & Cosmic Ray Astrophysics Branch of Naval Research Laboratory 

C in 1989. Significant improvements and "bug- extermination" have been 

C provided by A.F. Barghouty of Roanoke College. 

C 

c 

IMPLICIT NONE 
CHARACTER* 12 TARGET 
CHARACTER*80 SHIELDFILE 
INTEGER* 4 MARR,NELM 
PARAMETER {MARR=5000 , NELM=92) 

REAL* 4 INPUT_FLUX (NELM , MARR) , OUTPUT_FLUX (NELM , MARR ) 

REAL*4 TEMP_INPUT (NELM, MARR) , TEMP_FLUX (NELM, MARR) 

REAL*4 ELOWER, EUP PER , UPATHO , PATH, PSTEP , PSTEPMIN, PSTEPMAX 

REAL* 4 PATHOLD,DELTA_PATH,TEMP_PATH 

INTEGER*4 M, N, NSP, IZLO, I ZUP, IPATH, lULABEL 

REAL* 4 UPATH,UUPATH,FRACSHLD 

INTEGER*4 VERS ION_NUMBER , PROGRAM_CODE 

INTEGER*4 MAXSHIELD, NSHIELD, K, lELM, lARR 

PARAMETER (MAXSHIELD=500) 

DIMENSION UPATH (MAXSHIELD) , FRACSHLD (MAXSHIELD) 
CHARACTER* 5 UNITS_LABEL 
DIMENSION UNITS_LABEL(4) 

DATA UNITS^LABEL/ ' g/cm2 ' , ' mils ' , ' cm ' , ' M ! ! r ' / 

C 
C 

WRITE (6, 9998) 

9998 FORMATdx, ' TRANSPORT_DRIVER calculation started.', 
& ' Please stand by.') 



CALL GET_CREME96_VERSION(VERSION_NUMBER) 
PROGRAM_CODE=4 

C 

C Now set parametes for transport calculation. 



C Use recotnmendec 
C Use energy- dependent fragmentation cross -sections 
N=10 

C Use straight -ahead approximation; ignore energy spread of target fragments 
C (This takes a lot of time and generally has only very small effect.) 

NSP=0 

C 

C Set maximum & minimum PSTEP sizes allowed in transport 
PSTEPMIN=0.20 
PSTEPMAX=0.20 



IF (UPATHO.GT.0.0) THEN 
NSHIELD=1 
UPATH(1)=UPATH0 
FRACSHLD{1)=1.00 

ELSE 

CALL UNLOAD_SHIELDFILE(SHIELDFILE, 
& IPATH, NSHIELD, UPATH, FRACSHLD) 

ENDIF 

IULABEL=IPATH+1 

IF (IULABEL.GT.4) IULABEL=4 

_ PATHOLD=0. 0 

Q 

^ c 

D DO 1000 K=1,NSHIELD 

p WRITE(6,999) K, UP ATH (K) , UNI TS_LABEL (I ULAB EL) , FRACSHLD (K) 

fy 999 FORMATdx,' SHIELDING BIN ',14,' THICKNESS = ' , FIO . 4 , Ix, A5 , 
& ' FRACTION = ' , F8 . 4 ) 

UUPATH=UPATH (K) 

Get shielding thickness (PATH) in g/cm2 and transport step size: 
CALL UNLOAD_PATH (I PATH, UUPATH, TARGET, PATH, PSTEPMIN, PSTEPMAX, PSTEP) 

Now perform transport: 
IF (NSHIELD.EQ.l) THEN 
CALL UPROP96 (INPUT_FLUX, 
& ELOWER , EUPPER , M , I ZLO , I ZUP , 

& N , NSP , PATH , PSTEP , TARGET , 

& OUTPUT FLUX) 



ELSE 

Modification 8-16-96 by AJT: 

To speed up calculations through thick shielding distributions, 
allow output of one step to be input to the next step. 

DELTA_PATH=PATH- PATHOLD 

IF (DELTA_PATH.LT.O.) DELTA_PATH=0. 0 

DO 300 IELM=1,NELM 

DO 200 IARR=1,MARR 

IF (K.EQ.l) THEN 

TEMP_I NPUT ( I ELM , I ARR ) = INPUT_FLUX ( I ELM , I ARR ) 
TEMP_PATH=: PATH 

ELSEIF (K.GT.l .amd. DELTA_PATH . LT. PSTEP) THEN 
TEMP_INPUT (lELM, lARR) =INPUT_FLUX ( lELM, lARR) 
TEMP PATH=PATH 




GT . 1 . and . DELTA PATH . GE . PST^^^THEN 

TEMP_INPUT(IELM, lARR) =TEMP__FLUX ( lELM, lARR) 

TEMP_PATH=DELTA_PATH 

ENDIF 
200 CONTINUE 
3 00 CONTINUE 



' CALL UPROP96 (TEMP^INPUT, 

& ELOWER,EUPPER,M, IZLO, IZUP, 

& N-, NSP, TEMP_PATH, PSTEP, TARGET, 

& TEMP_FLUX) 
PATHOLD=PATH 



C Now add to weighted sum: 

DO 500 IELM=X,NELM 

DO 4 00 IARR=1,MARR 

OUTPUT_FLUX (lELM, lARR) =OUTPUT_FLUX ( lELM, lARR) + 

^ TEMP^FLUX ( lELM, lARR) *FRACSHLD (K) 

4 00 CONTINUE 
500 CONTINUE 

ENDIF 

1000 CONTINUE 

C 

WRITE(6, 9999) 

9999 FORMATdx,' TRANSPORT_DRIVER calculation completed. Thank you. 
& /,lx,' All fluxes are in units of particles/m2 -s-sr-MeV/nuC , 
& ' vs . energy in MeV/nuc . ' , 

& /,lx,' Recommended next step: 
& /, 5x, ' LETSPEC , 

& ' (RUN CREME96 :LETSPEC_DRIVER) ' 

& ' for heavy- ion induced SEUs;', 

• & /,2x,' or PUP (RUN CREME96:PROTON_UPSET_DRIVER) ' , 

& ' for proton- induced SEUs.') 



RETURN 
END 



REAL FUNCTI^p!RF96 (IZ,EN, YEAR,IMODE) 
C 

C THIS ROUTINE RETURNS THE DIFFERENTIAL FLUX IN PARTICLES/ { (M**2 ) * 

C STER*SEC*MEV/U) AS IT IS FOUND IN THE INTERPLANETARY MEDIUM 

C NEAR EARTH and OUTSIDE the magnetosphere 

C 

C . IZ = ATOMIC NUMBER OF THE IONS. 

C E = ENERGY (IN MEV/U) . 

C Y = THE YEAR: 1975 . 144=S0LAR MIN; 198 0 . 598=SOLAR MAX. 

C M = Particle environment model 

C 0 = non-solar particles only: GCR+ACR 

C 1 = "Worst day" Solar Energetic Particle Environment 

C 2 = "Worst week" Solar Energetic Particle Environment 

C . 3 = "Peak (worst 5-minutes) Solar Energetic Particle Environment 

C 

C 

IMPLICIT NONE 

INTEGER*4 IZ , IQ , IMODE , IDUM 

REAL* 4 EN , YEAR , GCRF , GCR_FLUX , ACRF , ACR_FLUX , SEP_FLUX 
CRF96=0.0 

IF (IMODE.LT.O. .or. IM0DE.GT.3) RETURN 

IF (EN.LT.O.) RETURN 

IF (IZ.LT.l .or. IZ.GT.92) RETURN 

ifl IF (IMODE.EQ.O) THEN 

Q C Get Galactic Cosmic Ray contribution 

m GCRF=GCR_FLUX(IZ,EN,YEAR, IDUM) 

ly C Get Anomalous Cosmic Ray contribution 

rT ACRF=0.0 

I DO 100 IQ=1,IZ 

ACRF= ACRF+ACR_FLUX ( I Z , IQ , EN , YEAR ) 
100 CONTINUE 

CRF96=GCRF+ACRF 
ELSEIF (IMODE.NE.O) THEN 
^ CRF96=SEP_FLUX (IZ, EN, IMODE) 

ENDIF 



RETURN 
END 



SUBROUTINE CTAB^^LOWER, EUPPER, N, NSP, I2L0, I2UP,^ll^ET) 
C** ********************** 

C SUBROUTINE CTABLE in Module UPROP.FOR 
C 

C Creates the auxiliary spallation cross section data file (CTABLE.DAT) if 
C it does not already exist. It also calculates energy losses associated 
C with spallation reactions (Sept. 1993) . 
C 

C Modified 06-05-96: add NSP to arguments, to control PARTIALS 

C Modified 11-17-97: add IMPLICIT NONE and variable- type declarations. 

C** ****************************************** ^t**^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 

C Parameters 
C 

C NELM Maximum atomic number of elements to be transported {<= 109) 
C MCS Maximum number of energies at which cross section data are 

C defined 

C ELOWER Lower energy bound of input and output spectra (>= 0.1 MeV) 

C EUPPER Upper energy bound of input and output spectra (<= 100000 MeV) 

C N Number of logarithmically equally- spaced energy bins at which 

C cross sections are evaluated (ABS (N) < MCS) 

C NSP =1 turns on nuclear dE/dx in PARTIALS; 0 otherwise 

C IZLO Least atomic number of elements transported (>= l) 

C IZUP Greatest atomic number of elements transported (<= 109) 

C TARGET Name of the target shielding material {<= 12 bytes) 

C 

C Important variables 
C 

C ECS Energy at each cross section grid point. 

C CT Temporary array for holding the spallation cross sections of 

C one element at one energy. 

C ELOSS Temporary array for holding the energy loss of one element 

C at one energy averaged over each fragment's isotopes. 

C TOTAL Abundance weighted elemental cross section. 

C C Cross section array for all elements at a single energy. 

C ENLOSS Energy loss array for all elements at a single energy averaged 

C each element's isotopes. 

C 

C Subprograms 
C 

C SUBROUTINE MFP (ENERGY, K, ALL, TARGET, PATH) 

C Returns the mean free path PATH in g/cm**2 at energy ENERGY for an 

C element with charge K and mass ALL in target material TARGET 

C 

C SUBROUTINE PARTIALS (ENERGY, K, ALL , TARGET, CT, ANORM) 

C Returns the partial spallation mean free paths CT in g/cm**2 at energy 
C ENERGY for an element with charge K and mass ALL in target material 
C TARGET . 
C 

C BLOCK DATA DOl 

C Defines the atomic masses of elements in the range 1 <= Z <= 109 and 

C places them in the array AMASS 

C 

C Data Files 
C 

C PERIODIC.DAT 

C Contains a list of the isotopes of each element and their natural 

C abundance . 

C 

C CTABLE.DAT 

C Contains nuclear spallation cross section data for the transport 



C calculation. Aut^^ically created by this subroucfne when needed. 

IMPLICIT NONE 
INTEGER NELM, MCS 
PARAMETER (NELM=92 , MCS=10 ) 

REAL*4 CABU(NELM, 9) ,TOTAL(NEIiM) 

REAL*4 ECS (MCS) , C (NELM, NELM) , CT (NELM) ,NORM(NELM) 

REAL*4 CS (NELM, NELM) , ENLOSS (NELM, NELM) , ELOSS (NELM) , ETOTL (NELM) 

INTEGER*4 CISC (NELM, 9) , STAT, CREME96_OPEN 

CHARACTER*12 TARGET, TARGET $ 

REAL* 4 AMASS 
COMMON/MASS /AMASS (109) 

REAL*4 ELOWER$,EUPPER$,ELOWER,EUPPER 
INTEGER*4 N$ , IZLO$ , I2UP$ , NSP$ , N, IZLO, I2UP, NSP 

INTEGER* 4 I,J,K,L 

REAL* 4 ENERGY, DENERGY , ALL , ANORM , PATH, REALNORM , FPRO , FALP 

DATA ELOWER$,EUPPER$,N$, IZLO$, IZUP$,NSP$/0. ,0., 0,0, 0,0/ 
DATA TARGET$/' '/ 

C FORMAT Statements 

C Format statement modified 6-5-96 by AJT to accomodate NSP 

100 F0RMAT(1X,2 (1PE10.4,2X) ,4 {I5,2X) , A12 , 2X, IPEIO . 4 ) 

200 FORMAT ( (IX, 6 (1PE11.4, 2X) ) ) 

300 FORMAT (6X, 9 {IX, 13 , IX, F4 . 2 ) ) 

C Otherwise perform calculation of cross sections 

C Read in list of elements from PERIODIC.DAT 

C OPEN (UNIT=15, FILE=' CREME96 : PERIODIC. DAT' , STATUS= ' OLD' , 

C & READONLY , SHARED ) 

Stat = creme96_open (' periodic.dat' , 'cr96tables' , 15, 'old' ) 
DO J=l,83 

READ (15, 300) (CISO(J,K) ,CABU(J,K) ,K=1,9) 
END DO 

CLOSE (UNIT=15) 
C Open output data file 

c OPEN (UNIT=13, FILE=' USER: CTABLE.DAT' ,STATUS='NEW' ) 

Stat = creme96_open(' ctable.dat' , 'user' ,13, 'new' ) 

C OPEN {XJNIT=1 7, FILE=' USER: SPTABLE.DAT' ,STATUS='NEW' ) 

Stat = creme96_open(' sptable.dat' , 'user' , 17, 'new' ) 

C Write header 

ELOWER$=ELOWER 
EUPPER$=:EUPPER 
N$=N 

IZLO$=IZLO 
IZUP$=IZUP 
NSP$=NSP 
TARGET$=TARGET 

WRITE (13,100) SLOWER, EUPPER,N, IZLO, I ZUP, NSP, TARGET 
WRITE (13, ' (A) ' ) ' ' 

WRITE (17,100) ELOWER,EUPPER,N, IZLO, I ZUP, NSP, TARGET 



WRITE (17, ' (A) ' 

Compute vector of energies 

IF {N.GE.2) THEN 
ECS(1)=EL0WER 

DENERGY= (EUPPER/ELOWER) ** (1 . /FLOAT (N-1) ) 

DO J=2,N 

ECS (J) =ECS (J-1) *DENERGY 

END DO 
ELSE 

ECS (1) =2000 . 
ENDIF 

Compute parameters 

DO J=1,N 

ENERGY=ECS (J) 
Initialize some arrays 

DO K=1,NELM 
TOTAL (K) =0. 
NORM(K)=0. 
DO I=1,NELM 
C{K,I)=0. 
ENLOSS{K, I)=0. 
CS(K,I)=0. 
END DO 
END DO 

DO K=IZLO,IZUP 

For each incident particle at each energy compute 
partial cross sections, total cross section, and the 
normalization factor. Average over isotopes. 

DO L=l,9 

IF (CABU(K,L) .GT.O. ) THEN 
ALL=REAL (CISO (K, L) ) 

CALL PARTIALS ( ENERGY , K , ALL , TARGET , CT , NSP , ELOSS , ANORM) 

CALL MFP ( ENERGY , K , ALL , TARGET , PATH ) 

DO 1=2, K+1 

C(I,K)=C(I,K) +CT(I)*CABU(K,L) 

CS(I,K) =C(I,K) ! Cross section w/o merging! 

END DO 

DO 1=1, K+1 ! Energy- loss averaged over isotopes of K 

ENLOSS (I,K) =ENLOSS {I,K) +ELOSS (I) *CABU(K,L) 
END DO 

NORM(K) =NORM(K) + ANORM *C ABU (K, L) 
TOTAL (K) =TOTAL(K) +PATH*CABU (K, L) 
ENDIF 
END DO 

Allow for further renormalization 
REALN0RM=1. 

Compute cross sections for proton and alpha production 
The procedure used here is taken from J.R. Letaw, 
Phys. Rev. C28, 2178 (1983). 





IF (K.GT.2) THEN 
C PF=:AMASS (K) /FLOAT (K) +0 . 67 

C ASSUME 15% He AND 85% H in product 

C FPR0=1./ (l.+2a/p) 

FPRO=0.73 9 
C FALP=l./(2.+ p/a) 

FALP=0.130 

C(1,K) =FPRO* (TOTAL (K) *FLOAT(K) -NORM{K) *REALNORM) 
C{2,K) =FALP* (TOTAL (K) *FLOAT{K) -NORM(K) *REALNORM) +C(2,K) 
ENDIF 

C Compute partials for alpha or proton into proton 

IF (K.EQ.l) C(1,K)=0. 

IF (K.EQ.2) C(1,K)=2.0*TOTAL(K) 

C CS(1,K)=C(1,K) 
C CS(2,K)=C(2,K) 
C 

C Merge total cross sections in 

C (K, K) =:C (K, K) -TOTAL (K) 

CS (K, K) =CS (K, K) +TOTAL (K) 
C Output results for current energy 
C 

END DO 

WRITE (13, 200) ({C(K,I) , K=IZLO, I2UP) , I=IZLO, IZUP) 

C 

C Nuclear stopping power table: Sept. 1993 

DO K=IZLO,IZUP 
ETOTL(K)=0. 
DO I=IZLO, IZUP 

ETOTL(K) =ETOTL{K) +ENLOSS (K, I) *CS {K, I) 
END DO 
END DO 

C 

WRITE (17, 200) (ETOTL(K) ,K=IZLO, IZUP) 

C 

END DO 

C 

C Close output file and stop 
CLOSE (UNIT=13) 
CLOSE {UNIT=17) 
RETURN 
END 
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SUBROUTINE SpUR ( X,Y, N,NMAX, NATURAL, YPl , YpJJrY2 , U ) 



Given arrays X and Y of length N containing a tabulated function 
Y{i) = f [X(i)] specified upon an set of montonically increasing 
arguments {x (1) <X (2) < . . . <x (N) } , SPLINE produces the array Y2 
containing the second derivative of the interpolating function at 
the same arguments. The boundary conditions are specified by the 
logical array 



TRUE. 


: Y2(l) 


= 0.0 


FALSE. 


: Y2(l) 


= YPl 


TRUE. 


: Y2 (N) 


= 0.0 


FALSE. 


: Y2 (N) 


= YPN 



NATURAL (2) 



Note that dummy arguments YPl and YPN must be supplied even if 
not used. 

The algorithm uses a scratch array U, which is included in the 
argument list so that its dimensions need not be adjusted for 
each application. The maximum dimension for the input and 
output arrays is NMAX^ 

Adapted from "Numerical Recipes", by W.H. Press et al . 

IMPLICIT REAL*8 (A-H, 0-Z) 
IMPLICIT REAL*4 (A-H, O-Z) ! f or use with minfun 
LOGICAL NATURAL (2) 

DIMENSION X{NMAX) , Y(NMAX), Y2 (NMAX) , U{NMAX) 
. . . Check arguments and boundary conditions . 
IF (N .GT. NMAX) STOP ' Too many points in SPLINE.' 

IF ( NATURAL (1) ) THEN 

Y2(l) = 0.0 

U (1) = 0.0 
ELSE 

Y2(l) = -0.5 

U (1) = (3.0 / (X(2) - X(1)))*({Y(2) - Yd))/ 
(X(2) - X(l)) - YPl) 

END IF 



C 
C 

c 
c 



IF ( NATURAL (2) ) THEN 

QN = 0.0 

UN = 0. 0 

Y2(N) = 0.0 

U (N) = 0.0 
ELSE 

QN = 0.5 

UN = (3.0/(X(N) - X(N-1)))*(YPN - (Y(N) 
(X(N) - X(N-l) ) ) 

END IF 



Y(N-l))/ 



Decomposition loop of tridiagonal algorithm. Y2 and U are used 
for temporary storage of decomposed factors. 



DO I = 2, N-1 

SIG = (X(I) - X(I-l)) / (X(I+1) 
P = SIG * Y2(I-1) + 2.0 



X(I-l)) 



Y2(I) = 
U (I) = 



m 

(6.0 * 



END DO 
Y2 (N) = 



1.0) / P 

{(Y(I + 1) - Yd) ) / (X(I + 1) - X(I) ) - 

(Yd) - Yd-D) / (x(i) - xd-i))) 
(x(i+i) - xd-D) - siG*ud-i)) / P 



(UN - QN*U(N-1)) / (QN*Y2{N-1) +1.0) 



... Backsubstitution loop. 

DO K = N-l, 1, -1 

Y2(K) = Y2(K)*Y2(K+1) + U{K) 
END DO 



RETURN 
END 

SUBROUTINE SPLINT ( XA,YA,Y2A, N, X,Y ) 

Given arrays XA and YA of length N, which tabulate a function 
(with the XA(i)'s in order), and given the array Y2A, which is 
output from SPLINE above, and given a value of X, this routine 
returns a cubic-spline interpolated value Y. 

Adapted from "Numerical Recipes", by W.H. Press et al. 

IMPLICIT REAL*8 (A-H, O-Z) 
IMPLICIT REAL*4 (A-H, O-Z) 1 f or use with minfun 
DIMENSION XA{N) , YA (N) , Y2A(N) 

. , . Locate nearest base points by bisection. 

KLO = 1 
KHI = N 

1 IF ( (KHI - KLO) .GT. 1) THEN 
K = (KHI + KLO) / 2 
IF (XA{K) .GT. X) THEN 

KHI = K 
ELSE 

KLO = K 
END IF 
GO TO 1 
END IF 

H = XA(KHI) - XA(KLO) 

IF (H .EQ. 0.0) STOP ' Arguments for SPLINE must be unique.' 

... Evaluate cubic spline polynomial. 

A = (XA(KHI) - X ) / H 

B = (X - XA(KLO) ) / H 

Y = A*YA(KLO) + B*YA(KHI) 
. + ( A*(A*A - 1)*Y2A(KL0) + B* (B*B - 1)*Y2A(KHI) ) *H*H / 6.0 



RETURN 
END 



REAL FUNCTIO] 



'96 (IZ, EN, YEAR, IMODE) 



C 
C 

c 
c 
c 
c 
c 
c 
c 
c 



IZ = ION ATOMIC NUMBER. 

EN = ION ENERGY IN MEV/AMU. 



THIS ROUTINE OBTAINS DIFFERENTIAL PARTICLE FLUXES AND 
APPLIES THE GEOMAGNETIC CUTOFF TRANSMISSION FUNCTION 
AND RETURNS THE RESULTING FLUX, MODULATED TO THE 
ORBIT-AVERAGE CUTOFF. 



YEAR = YEAR (1975.144 = SOLAR MIN. / 1980.598 = SOLAR MAX.). 



IMPLICIT NONE 

INTEGER* 4 IZ, IQ, IMODE, KZ , IDUM, J 

REAL*4 EN , YEAR , A , SEP_QSTATES , AN, Q , P , TRF 

REAL*4 MAGNETIC_RIGIDITY, GET_GTF, GCR_FLUX, ACR_FLUX, SEP_FLUX 
REAL*4 GCRF,ACRF,ACRFQ,SF 
COMMON/MAS S / A { 1 0 9 ) 

COMMON/SEP_QSTATES/SEP_QSTATES (30, 30) 
CUT96=0.0 

IF ( IMODE. LT.O .or. IMODE. GT. 3) RETURN 

IF (EN. LT.O.) RETURN 

IF (IZ.LT.l .or. IZ.GT.92) RETURN 

AN=A(IZ) 

IF (IMODE. EQ.O) THEN 

Galactic-Cosmic Ray Component 
Q=IZ*1.0 

P=MAGNETIC_RIGIDITY (EN, Q, AN) 
TRF=GET_GTF(P) 
. GCRF=GCR_FLUX (IZ, EN, YEAR, IDUM) 
CUT96=CUT96+GCRF*TRF 

Anomalous Component 

ACRF=0.0 

DO 100 IQ=1,IZ 

ACRFQ=ACR_FLUX (IZ, IQ, EN, YEAR) 
I F ( ACRFQ . GT . 0 ) THEN 
Q=IQ*1.0 

P=MAGNETIC_RIGIDITY(EN,Q,AN) 
TRF=GET_GTF(P) 
ACRF=ACRF+ACRFQ*TRF 
ENDIF 
100 CONTINUE 

CUT96=CUT96+ACRF 

ELSEIF { IMODE. NE.O) THEN 

Solar Energetic Particle Contribution 

SF=SEP_FLUX (IZ, EN, IMODE) 
IF (SF.EQ.O.) RETURN 
KZ=IZ 



C 



For elements heavier than Zn, use Zn charge states 
IF (KZ.GT.30) KZ=30 



o 

Q 
O 

ru 

Q 
w 

S 

m 

VP 

SI 



DO 3200 J= 
TRF=0.0 

IF (SEP_QSTATES (KZ, J) .GT. l.OE-8) THEN 
Q=J*1.0 

P=MAGNETIC_RIGIDITY (EN, Q, AN) 
TRF=GET_GTF{P) 
ENDIF 

CUT96=CUT96+SF*SEP_QSTATES (KZ, J) *TRF 
3200 CONTINUE 

ENDIF 

RETURN 
END 




BLOCK DATA DOl 

C Atomic Mass Tabulation from Review of Particle Properties 

Physics Letters B204 (April, 1988) 

COMMON/MASS/AMASS (109) 
DATA AMASS/ 

& 1.00794,4.002602,6.941,9.012182,10.811,12.011,14.00674,15 9994 
& 18.9984032,20.1797,22.989768,24.305,26.981539,28.0855,30.973762, 
& 32.066,35.4527,39. 948, 3 9.0983,40.078,44.95591,47.88,50.9415, 
& 51.9961,54.93805,55.847,58.9332,58.69,63.546,65.39,69.723, 
& 72.61,74.92159,78. 96,79.904,83.80,85.4678,87.62,88.90585,91.224, 
& 92.90638, 95.94,98. ,101.07,102.9055,106.42,107.8682,112.411, 
& 114.82,118.71,121.75,127.6,126.90447,131.29,132.90543,137.327, 
& 138.9055,140.115,140.90765,144.24,145,150.36,151.965,157.25, 
& 158.92534,162 .5, 164.93032,167.26, 168.93421,173.04,174.967, 
& 178.49,180.9479,183.85,186.207,190.2,192.22,195.08,196.96654, 
& 200.59,204.3833,207.2,208.98037,209. ,210. ,222., 223. ,226.0254,' 
& 227.0278,232.0381,231.03588,238.0289,237.0482,244. ,243. ,247. i 

& 247., 251., 252., 257., 258., 259., 260., 261., 262., 263. ,262. ,265,266/ 
END 



REAL*4 FUNCl^f DIFPLD (S , L, W, H) 



THIS FUNCTION RETURNS THE PROBABILITY DENSITY FOR PATHS 
OF LENGTH S THROUGH A PARALLELEPIPED OF DIMENSIONS 
L, W, AND H. S, L, W, AND H MUST BE IN THE SAME UNITS. 

THIS IS AN EXACT SOLUTION, DUE TO M. D. PETROFF OF 
ROCKWELL INTERNATIONAL (SEE J. C. PICKEL AND J. T. BLANDFORD, 
IEEE TRANS. ON NUCL. SCI. NS-27, 1006(1980)) WITH 
SIMPLIFICATIONS DUE TO WARREN BENDEL OF NRL (PRIVATE 
COMMUNICATION) . THE EQUATION NUMBERS REFER TO THE APPENDIX 
OF PICKEL AND BLANDFORD' S PAPER. 

Modified by AJT 4-2-96: IMPLICIT NONE and variable- type declarations 
added 



IMPLICIT NONE 
REAL*4 S,L,H,W,AP,G 

EQUATION (A- 7) 

AP=3 . * (H*W+H*L+L*W) 

EQUATION (A- 8) 

DIFPLD= (G{S,L,W,H)+G(S,W,L,H)+G{S,L,H,W)+G(S,W,H,L) + 

G(S,H,W,L) +G(S,H,L,W) ) / ( 3 . 1416 *AP) 

RETURN 

END 

REAL*4 FUNCTION G{S,X,Y,Z) 
IMPLICIT NONE 

REAL*4 S,X, Y, Z,KSQ,T,RSQ,R, V,PSQ,QSQ,TSQ 

PRELIMINARY DEFINITIONS 

KSQ=X*X+Y*Y 

TSQ=X*X+Z*Z 

T=SQRT{TSQ) 

RSQ=KSQ+Z*Z 

R=SQRT(RSQ) 

V=12.*X*Y*Z*Z 

PSQ=S*S-Z*Z 

QSQ=S*S-X*X-Z*Z 

IF( (S.GE.0.0) .AND. (S.LT.Z) ) GO TO 10 
IF{(S.GE.Z) .AND. (S.LT.T) )G0 TO 20 
IF{{S.GE.T) .AND. (S.LE.R) )G0 TO 30 
G=0.0 
RETURN 

EQUATION (A- 9) 

G=8 . *Y*Y*Z/KSQ-S* (3 . *X*Y/ (R*T) ) **2 
RETURN 

EQUATION (A- 10) 

G=S* (3 .*Y/SQRT(KSQ) )**2-S* (3 . *X*Y/ (T*R) ) **2 
-X* {SQRT(PSQ) /S) * (8.+4 .*Z*Z/ (S*S) ) 
+ {V*ATAN(Y/X) - (Y*Z*Z/SQRT(KSQ) ) **2) / (S*S*S) 



RETURN 




C 

C EQUATION (A- 11) 

C 

30 G=-S* (3 . *X*Z/ (R*SQRT (KSQ) ) ) **2 

1 + {X*X*Z*Z* (Z*Z/KSQ-3 . ) +V*ATAN{Y/X) ) / (S*S*S) 

2 +Y*Z*Z* (SQRT (QSQ) /S) * (8 . /TSQ+4 . / (S*S) ) 

3 -{V/{S*S*S))*ACOS(X/SQRT(PSQ)) 

RETURN 
END 



PROGRAM DOSE 




IMPLICIT NONE 

CHARACTER*80 INFILE, OUTFILE 

REAL*4 EMINCUT,EMAXCUT,ELOWER,EUPPER 

INTEGER*4 IZMIN, IZMAX , IZLO, IZUP, M, L 

CHARACTER* 12 TARGET 

INTEGER*4 MARR , NELM , LARR 

PARAMETER (MARR=5000 , NEIiM=92 , IiARR=1002 ) 
REAL* 4 INPUT_FLUX ( NELM , MARR ) , LETFLUX { LARR ) 
INTEGER*4 VERSION^NUMBER , PROGRAM_CODE 
REAL*4 LETMINMG,LETMAXMG,LETMIN,LETMAX 
REAL* 4 DOSE_PER_SECOND, ACCUMULATED_DOSE 
INTEGER* 4 MODEL_TYPE 

Get parameters of dose calculation: 

CALL INIDOSE (INFILE, LETMINMG,LETMAXMG, 

IZMIN, IZMAX,EMINCUT,EMAXCUT, 
TARGET, OUTFILE) 

Unload input particle flux file into array: 

CALL UNLOAD_PARTIAL_FLUX (INFILE, IZMIN, IZMAX, EMINCUT, EMAXCUT, 

ELOWER , EUPPER , M , I ZLO , I ZUP , 
INPUT FLUX) 



Check model -type 

CALL GET_CREME96_FLUX_MODEL ( INFILE , MODEL_TYPE ) 

Now do integral LET spectrum calculation: 

LETMIN=LETMINMG*1000 . 0 
LETMAX=LETMAXMG*1000 . 0 
L=LARR 

CALL ULET9 6 (LETMIN,LETMAX, TARGET, 
* ELOWER, EUPPER, M, IZLO, IZUP, 

& INPUT_FLUX , L , LETFLUX ) 



Now do numerical integration to get dose value: 

DOSE_PER_SECOND = average dose rate (rads /second) 
ACCUMULATED_DOSE = krad or krad/sec, depending on MODEL_TYPE 

CALL CREME96_DOSE (L, LETM IN, LETMAX, LETFLUX, MODEL_TYPE, 
& VERS ION_NUMBER , PROGRAM_CODE , 

& DOSE_PER_SEC0ND , ACCUMULATED_DOSE ) 

Now write dose results to output file: 

CALL OUTPUT_CREME96_DOSE (INFILE, IZLO, IZUP, LETMIN, LETMAX, 

* EMINCUT , EMAXCUT , TARGET , MODEL_TYPE , 

* VERS ION_NUMBER , PROGRAM_CODE , 

* DOSE_PER_SECOND , ACCUMULATED_DOSE , 
& OUTFILE) 



STOP 
END 
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SUBROUTINE EV1WRVTE_SEU_CR0SS_SECTI0N 
& (EN, NPTS , IPARAM, PARAMS , XSECT_FILE , XSECT) 

Subroutine to evaluate SEU cross-section for an array 
of abscissa values : 

This same routine is used for both proton- induced and heavy- ion 
induced cross -sections; but the dimensions of the inputs and 
output are different in the two cases. 



INPUTS: EN: array of proton energies (in MeV) for proton SEUS 

OR array of LET values (in MeV-cm2/mg) for heavy-ion SEUs 
NPTS: number of points in the array 
IPARAM: specifies cross-section model or format: 

IPARAM=0: table of values 

IPARAM=1: Bendel 1-parameter fit 

IPARAM=:2: Bendel 2-parameter fit 

IPARAM=4: Weibull fit 
PARAMS: array of at least dimension IPARAM, 

the fit parameters for IPARAM=1,2, 



containing 
or 4 . 



OUTPUT: 



XSECT_FILE: name of file containing cross -section table 
(for IPARAM=0 option) . Cross-section values 
will be linearly interpolated in this table, 
with zero below the first entry's abscissae 
and a plateau value at the the last entry's 
ordinate 

array containing the cross- section values 
corresponding to values in EN array 
in l.OE-12 cm2/bit (for proton cross -sections) 
in l.OE-8 cm2/bit (for heavy ion cross-sections) 



XSECT: 



OR 



Written by: Allan J. Tylka 
Code 7654 

Naval Research Laboratory 
Washington, DC 20375-5352 
tylka®crs2 .nrl .navy .mil 

Last update: 29 March 1996 



IMPLICIT NONE 

INTEGER* 4 I PARAM , K , NPTS , NS V , NS VMAX 

REAL* 4 EN, XSECT, PARAMS , A, B , O, W, P , BENDELl , BENDEL2 , WEIBULL 
REAL*4 XV, YV 

REAL* 4 INTERPOLATE_XSECT_TABLE 
CHARACTER* 80 XSECT_FILE 
PARAMETER (NSVMAX=5000 ) 
DIMENSION XV (NSVMAX) , YV (NSVMAX) 
DIMENSION EN(1) ,XSECT(1) , PARAMS (4) 



IF (IPARAM. EQ. 0) THEN 

CALL UNLOAD_XSECT_FILE (XSECT_FILE, NSV, XV, YV) 
ELSEIF ( IPARAM. EQ.l) THEN 

A= PARAMS (1) 
ELSEIF { IPARAM. EQ. 2) THEN 

A=PARAMS(1) 

B=PARAMS (2) 



ELSEIF {IPJ^Pi.EQ.4) THEN 
0=PARAMS (1) 
W=PARAMS(2) 
P=PARAMS (3) 
A=PARAMS (4) 

ELSE 

WRITE (6, 9999) IPARAM 
9999 FORMATC® 10001 ABNORMAL TERMINATION: 

& /,lx, ' ERROR in EVALUATE_SEU_CROSS_SECTION: 

& /,lx,' CROSS -SECTION STEERING CODE UNKNOWN: ',15, 

& /,lx,' STOP.') 

STOP 
ENDIF 



IF (NPTS.LE.O) RETURN 
DO 1000 K=1,NPTS 
XSECT(K) =0.0 
IF (IPARAM. EQ.O) THEN 

XSECT (K) =INTERPOLATE_XSECT_TABLE (NSV, XV, YV, EN (K) ) 
ELSEIF ( IPARAM. EQ.l) THEN 

XSECT (K) =BENDEL1 (A, EN (K) ) 
ELSEIF ( IPARAM. EQ. 2) THEN 

XSECT {K)=BENDEL2 (A,B,EN{K) ) 
ELSEIF ( IPARAM. EQ. 4) THEN 

XSECT (K) =WEIBXniL(0,W,P, A,EN(K) ) 
ENDIF 

1000 CONTINUE 
RETURN 
END 



)^^Z , I A , JZ , JA , K2 , KA , ELAB , dKE , S 10^11^) 



SUBROUTINE EJLOSW^Z, lA, JZ, JA, K2, KA, ELAB, dKE, SigmSRE) 
C 

C Computes the average energy loss dKE and variance SigmaKE when 
C nuclide (IZ,IA) impinges on medium (J2,JA) 

*C producing fragment (KZ,KA). 

C Fragment is no longer at energy ENERGY, i.e. straight- 

C ahead approximation is relaxed. Medium can be Hydrogen, 

C Helium, or any other nuclide. 

C 

C Based on the paper by Barghouty, Tsao, and Silberberg, 23rd ICRC, 

C Calgary, Canada, 1993. 

C 

C January 1994 

C 

C 

INTEGER AP, ZP, AT, ZT, AA, AAZ, BB, BBZ, CC, CCZ 

INTEGER AF, ZF,AFF, ZFF,DELTA_A, DELTA Z, AC, ZC, ATO , ZTO 



DATA WN,EFERMI/931.504,38./ 

DATA CONST,RO,PI/1.44, 1.2, 3.14159/ 

DATA Ebin/20./ 

DATA IENT/0/ 

C 

D ^ 

7q IF (lENT.EQ.O) THEN 

IENT=1 

S WRITE {6, 9999) 

9999 FORMATdx,' In nuclear transport: Subroutine E_LOSS active.') 

L? ENDIF 
H dKE=0. 

: . t 

Y^' SigmaKE=9. 

C ' 

= IF(ELAB.LT.50. ) RETURN 

C 

ru zp=iz 

W AP=IA 

H ZT=:JZ 

yD AT=JA 
ZF=KZ 
AF=KA 

C 

ZFF=KZ 
AFF=KA 

C 

IF(AF.GE.AP) RETURN 

C 

PLAB=SQRT{ (ELAB+WN) **2-WN**2) 
Pbin= (Ebin/ELAB) *Plab 

C 

C Energy loss calculation for Z (TARGET) <6: 

SCALE=1 . 

IF(ZT.LT.6) THEN 

SCALE= (6 .+ZT) /12. 

AT=12 

ZT=6 
END IF 

C 

C Energy loss calculation for Z (PROJECTILE) <6 : 

SCALE=SCALE*1. 



DP=0. 
RETURN 
ELSE 

SCALE=SCALE* (6 . +2P) /12 . 
AP=12 
ZP=6 
END IF 
END IF 



IF(ZP.LT.6) THI 

IF(ZP.EQ.l) THEN 
dKE=0. 



-Energy loss calculation for all other nuclides: 
CALL GLBR ( AP , 2P , AT , 2T , AA , AA2 , BB , BBZ , CC , CCZ ) 
Projectile and target A and Z numbers: 
AO=AP 
AZO=ZP 
BO=AT 
BZ0=2T 
A=AA 
AZ=AA2 
B=BB 
BZ=BB2 
C=CC 
CZ=CC2 



Q=HEAT{A0,AZ0,B0,BZ0,ELAB,A,AZ,B,B2,C,CZ,TA,T3,TC,Temp) 

Relative size of fragment to source "A" : 
,DELTA_A=A-AF 
DELTA_2=A2-2F 

Coulomb Barrier: 

Ec = (CONST*(AZ-1.))/(RO*(SQRT(A-1.)+1.)) 
IF (DELTA__A . GE . 1 ) THEN 

CHECK IF FRAGMENT IS TOO S^4ALL TO BE A SPALLATION PRODUCT. 
Here we make the assumption that if the fragme-t is too small, 
i.e., fragment size < AP/2, it is accompanied by a heavy partner. 
We proceed to calculate the loss of that heav^- partner assuming 
further that both partners suffer the same energy loss per nucleon. 

IF(AF.LT.DELTA_A) THEN 

AF=DELTA_A 

ZF=DELTA_Z 

GO TO 8 
END IF. 

AFMASS=AF*WN+DROP (AF, ZF) 
AMASS=A*WN+DROP (A, AZ) 
CONSERVE MASS: 
DMAS S = AMAS S - AFMAS S 

TD = DELTA_A*(TA+ ( 3 . /5 . ) *EFERMI ) + DELTA_Z*Hc 
CONSERVE TOTAL ENERGY: 

TF = (AMASS+TA*A) - (DMASS+TD) - AFMASS 
PF = SQRT( (AFMASS+TF) **2-AFMASS**2) 
dKE=ELAB-TF/AF 
dKE=SCALE*dKE 



IF(dKE.LT. 
PERC= (dKE/ELAB) *100 . 
DP=PLAB-PF/AF 
ELSE 
AC=AP+{AT-B) 
ZC=ZP+ (ZT-BZ) 
DELTA_A=AC-AF 
DELTA_Z=ZC-ZF 
C Coulomb Barrier: 

EC = (CONST* (ZC-1.) )/{RO*{SQRT(AC-l.)+l.) ) 

C 



AFMASS=AF*WN+DROP (AF, ZF) 
ACMASS=AC*WN+DROP (AC, ZC) 
C CONSERVE MASS: 

DMAS S = ACMAS S - AFMAS S 

TCN= ( (AP-DELTA_A) *ELAB+ (AT-B) *TA+DELTA_A*TA) /AC 
TD = DELTA_A*(TCN+{3./5.)*EFERMI)+DELTA_Z*Ec 
C CONSERVE TOTAL. ENERGY: 

TF = (ACMASS+TCN*AC) - (DMASS+TD) - AFMASS 
PF = SQRT( (AFMASS+TF) **2-AFMASS**2) 
dKE=:ELAB-TF/AF 
dKE=SCALE*dKE 
IF{dKE.LT.O. ) dKE=0. 
DP=PLAB-PF/AF 
END IF 

3 ^ 

C Sigma in KE loss distribution: 

2? C SIGMAKE = Temp*SQRT(9.*(AP-AFF)/AP)*(SQRT(.667*dKE/Temp)+l.) 

^ SIGMAKE= (SIGMAKE/ELAB) *100 . 



IS; C 



C 



RETURN 
END 



= FUNCTION HEATCAO, AZO,BO,BZO,ELAB,A,AZ,B,BZ,C,CZ,TA,TB,TC,Temp) 

M C 

ru C CALCULATES THE ENERGY AND MOMENTUM OF THE THREE SOURCES A,B,C 

ly c 

y: COMMON/RAPIDITY/YAO , YBO ^ YA, YB, YC 

^ DATA WN/931.504/ 

Si DATA PI, EPS/3. 14159, 0.03/ 

C 

C Transport parameters; 

C XO Energy leaked to the spectators 

C YO Longitudinal momentum degradation of spectators 

C ZO Tranveres momentum transfer: 

C 

DATA XO, Y0,Z0/.05, .25, 60./ 

C 

C Sources A and Z numbers : 

C Note These are estimated using Glauber theory. They are 

C impact -parameter averaged numbers I 

C A is projectile spectator 

C B is target spectator 

C and C is participant source. 

C 

C Masses of sources A, B, and C: 

AOMAS = AO * WN+DROP ( AO , AZ 0 ) 
B0MAS=B0*WN+DROP(B0,BZ0) 
AMAS=A* WN+DROP (A, AZ) 
BMAS=B*WN+DROP (B,BZ) 



CMAS=C*WN+DR0^^C2) 

EA= AOMAS +A0 * ELAB 

PA= SQRT { EA* * 2 - AOMAS * * 2 ) , 

BETAO=:PA/EA 

GAMMA0=1 . /SQRT (1 . -BETA0**2 ) 

YA0 = 0.5*ALOG(ABS ( (l.+BETAO) / (l.-BETAO) ) ) 

EO=EA+BOMAS 

In cm. frame: 
V=PA/EO 

G=1./SQRT(1.-V**2) 

BETA_CM=V 

GAMMA_CM=G 

PAO=:G* (PA-EA*V) 

E0=SQRT(E0**2-PA**2) 

Transport parameters X, Y, and Z, averaged over impact parameter 
[Recalculated 15 Dec. 1993] 

T_FACTOR= (BETA_CM/BETAO) /GAMMA0**2 

X = {1./2.) * XO * T_FACTOR 
y = (1./2.) * YO * T_FACTOR 
Z = (PI/4.) * ZO * T FACTOR 



Momenta of sources A, B, and C in the cm. frame: 

PA= (1. -Y) *PAO*A/AO 

PB=:- (1 . -Y) *PAO*B/BO 

PC=-PA-PB 

PAX= Z*A 

PBX=-PAX 

PCX=-PAX-PBX 

Iteration to find Q, the generated heat, conserving energy: 
N=l 
Q=0. 
DQ=0. 
Q=Q+DQ 
N=N+1 

WA=AMAS+A*Q*X 
WB=BMAS+B*Q*X 

WC=CMAS+C*Q* (1 . + (1 . -X) * (A+B) /C) 
EA=SQRT (PAX**2+PA**2+WA**2) 
EB=SQRT(PBX**2+PB**2+WB**2) 
EC=SQRT(PCX**2+PC**2+WC**2) 
DQ= (EO-EA-EB-EC) / (AO+BO) 
CHECK AVAILABLE ENERGY 
HEAT=DQ 

IF (Q.EQ.O. .AND.DQ.LT.O. ) RETURN 
IF (ABS (DQ) .GT.EPS) GO TO 10 
EOO=EA+EB+EC 

IF ( (EO-EOO) .GT. ( (AO+BO) *EPS) ) PRINT 101, EO,EOO 

Excitation Energy/nucleon: 
Temp=2 . /3 . *Q*SQRT (T_FACTOR) 
HEAT=Q 

TA=(EA-AMAS)/A 

TB=(EB-BMAS)/B 



TC=(EC-CMAS 

C 

Q=G* (EA+PA*V) 
PA=:G* (PA+EA*V) 
EA=Q 

C 

Q=G* {EB+PB*V) 
PB=G* (PB+EB*V) 
EB=Q 

C 

Q=G* (EC+PC*V) 
PC=G* (PC+EC*V) 
EC=Q 

C 

TA= (EA-AMAS) /A 
TB= (EB-BMAS) /B 
TC= (EC-CMAS) /C 
EE=EA+EB+EC 
P=PA+PB+PC 
E00=SQRT{EE**2-P**2) 

C 

C IF ( (EO-EOO) .GT. { (AO+BO) *EPS) ) PRINT 101, EO,EOO, EPS 

C 

RETURN 

C 

101 FORMAT (2X,20H ENERGY CONSERVATION, 3 F12 . 5) 
12 FORMAT (/2X, 6E12 . 4//2X, 6E12 .4) 
END 

C 

FUNCTION DROP (A, Z) 

C 

C CALCULATES THE LYSEKIL NUCLEAR MASS DEFECT+WIGNER+PAIRING+SHIFT 

C 

DATA Al , A2 , C3 , CAPPA/15 . 4941 , 17 . 9439, 0 . 7053 , 1 . 7826 / 
DATA C4/1.1533/ 

DATA WA,WN,WP/931. 504, 8. 07169, 7.28922/ 
DATA WIG, D1,D2, SHIFT/30. ,12. ,10. ,50./ 

DROP=0 . 

IF (A.LT.0.9) RETURN 
A3=A**0. 333333 

EN=(-A1*A+A2*A3**2) * (1. -CAPPA* (l.-2.*Z/A) **2) 
EC= (C3/A3-C4/A) *2**2 
W= (A-Z) *WN+Z*WP 

DROP=:W 

IF (A.LE.4.) RETURN 
E=EN+EC+W 

T=ABS(1.-2.*Z/A) 

EW=WIG*T 

IA2=A/2.+0.1 

IF {A-2.*IA2-0.1) 10,10,20 

10 IZ2=Z/2.+0.1 
EP=D1/SQRT (A) -D2/A 

IF . (Z-2.*IZ2-0.1) 11,11,15 

11 EW=EW-EP 
GO TO 30 

15 EW=EW+EP 

IF (IA2.EQ.2*IZ2) EW=EW+WIG/A 
GO TO 30 




20 EW=EW+D2/A 
30 CONTINUE 

E=E+EW+SHIFT/A 

DROP==E 

C 

RETURN 
END 

C 
C 

SUBROUTINE GLBR(AP, ZP, AT, ZT, AA, AAZ , BE , BBZ , CC, CCZ) 

C 

C Calculates (average) numbers of proj . and target participants according 

C to Glauber theory, see, e.g., Tsao et al., PRC 47, 1257 (1993). 

C 

INTEGER AP , ZP , AT , ZT , AA, AAZ , BB , BBZ , CC , CCZ 
INTEGER ZERO_A, ZERO_Z 

C 

DATA PI, RO/3. 14159, 1.36/ 
DATA P13,P23/0. 33333, 0.66667/ 

C 

FACTORl = (AP**P13+AT**P13) **2 
FACT0R2 = AP**P23+2*AP**P13*AT**P13 

C 

C Participants : 

Q AP_P = AP * AT**P23 / FACTORl 

,fi AT_P = AT * AP**P23 / FACTORl 

q ZP_P = ZP * AT**P23 / FACTORl 

p ZT_P = ZT * AP**P23 / FACTORl 

^ C Participant source "C" : 

ffj CC = NINT(AP_P) +NINT(AT_P) 

r: CCZ = NINT(ZP_P) +NINT(ZT_P) 

^" c 

_ C Projectile spectator source "A": 

[f: AA = AP - NINT(AP_P) 
AAZ = ZP - NINT.(ZP P) 

y c 

r=^ C Target spectator source "B": 

4) BB = AT - NINT(AT_P) 

Si BBZ = ZT - NINT(ZT_P) 
C 

C Check baryon number conservation: 



C 



C 
C 



ZERO_A = (AP+AT) - (AA+BB+CC) 
ZERO_Z = (ZP+ZT) - (AAZ+BBZ+CCZ) 
IF(ZERO_A.NE.O.OR.ZERO_C.NE.O) THEN 

PRINT*,' ***Baryon Number Conservation***' 
END IF 



RETURN 
END 



PRCX5RAM FLUX DR! 




Driver program for generating CREME96 model fluxes 
IMPLICIT NONE 

INTEGER*4 IZMIN, IZMAX , IMODE , ITRANS , M 
REAL*4 EMIN,EMAX, YEAR 

CHARACTER*80 GTRANSFILE, TRAPDFILE, FLXFILE 

INTEGER* 4 MARR, NELM, VERSION_NUMBER, PROGRAM_CODE 
PARAMETER. (MARR=5000 , NELM=92 ) 
REAL*4 E,FLX 

DIMENSION E (MARR) , FLX (NELM, MARR) 

CALL INIFLUX{IZMIN, IZMAX , EMIN, EMAX , YEAR, IMODE, ITRANS, 
GTRANSFILE, TRAPDFILE, FLXFILE) 



CALL CREME96_FLUX{IZMIN, IZMAX, EMIN, EMAX, YEAR, IMODE, I TRANS , 

GTRANSFILE, TRAPDFILE, 
VERSION_NUMBER, PROGRAM_CODE , 
M,E,FLX) 



CALL OUTPUT_CREME96_FLUX (IZMIN, IZMAX) EMIN, EMAX, 

YEAR , IMODE , I TRANS , 
GTRANSFILE , TRAPDFILE , 
VERSION_NUMBER, PROGRAM_CODE , 
M, FLX, FLXFILE) 



STOP 
END 



c- 

c 

c 



REAL FUNCTION ^■f_FLUX(I2IN,EEZ, YDUM, IPDUM) 
IMPLICIT NONE 

INTEGER I , IZIN, IPDUM, IMonthMean, Nmonths 

Nmonths needs to be odd number to properly center on input month 
PARAMETER (Nmonths=l) 

REAL EEZ , YDUM , YEARAVG (Nmonths ) , OCR MONTHLY FLUX 



C Perform average over neighboring months to smooth out GCR fluxes 

GCR_FLUX=0.0 
IF (Nmonths .LE. 1) THEN 
YearAvg(l)=YDUM 

GCR_FLUX=GCR_MONTHLY_FLUX (IZIN, EEZ, YDUM, IPDUM) 

IF (Nmonths .LT. 1) THEN 
WRITE{*,222) 

222 FORMAT (IX, 'Using number of months = 1 in GCR flux averages') 

ENDIF 

ELSE 

IMonthMean=: (Nmonths+1) /2 
DO I=l,NMonths 

YearAvg(I) =YDUM + FLOAT (I-IMonthMean) /12 . 0 

GCR_FLUX=GCR_FLUX + 
& GCR_MONTHLY_FLUX ( IZIN, EEZ , YearAvg ( I ) , IPDUM) 

ENDDO 

GCR_FLUX=GCR_FLUX/FLOAT (Nmonths) 
ENDIF 

RETURN 

END 



REAL FUNCTION GCR_MONTHLY_FLUX ( I ZIN , EEZ , YDUM , I PDUM) 
IMPLICIT NONE 



INTEGER I, IZIN, IZ, IPDUM, lENT, K, J, Jyear 

INTEGER lYMIN, lYMAX, lY 

REAL*4 MO,EEZ,EN,R,RO,YDUM,PI , 

REAL W (12, 300) ,WF(3600) , AN ( 92 ) , d (28 ) , b (28 ) , to ( 28 ) 
REAL A(28) ,DD(28) ,ALPHA(28) ,GAMMA(28) 
REAL Z , T , TO , BETA, S INE , ARGl , ARG2 , DELTA , F , DRDE , FLUX 
EQUIVALENCE (W (12, 300) ,WF(3600) ) 
CX DIMENSION ENVAL (100) , FVAL (100) 'unused 



C 



For extrapolating wolf numbers to dates outside of data ranges. 



c 




C assuming a ^Bfear periodicity. PRB. 

REAL YearMin, YearMax 

REAL Tmin,SINE_TERM,SGN,DT,Tmax,SUM,WS 

INTEGER MonthMin, MonthMax, IBmin, IBmax, IB,N, STAT, CREME96_OPEN 

C made separate array for reading wolf number file. This allows 

C -input wolf numbers to start and end and any particular date, 

C and preserves the original structure with W and WF variables. 

REAL WOLFTMP{3600) 

C 

C ENTER Tmax AND THE REST MASS OF A NUCLEON, MO 



DATA Tmax/14. 5/, MO/931. 162/ 



C 

C ATOMIC MASS TABLE 

C 

DATA (ANd) ,I=1,92)/1. ,4, ,6.9, 

1 9. ,10.8,12. ,14. ,16. ,19. ,20.2,23. ,24.3,27. ,28. , 

2 31. ,32. ,35.5,39.9,39. ,40. ,45. ,47.9,50.9, 

3 52. ,54.9,55.8,58.9,58.7,63.5,65.4,69.7,72.6, 

4 74.9,79. ,79.9,83.8,85.5,87.6,88.9,91.2,92.9,95.9, 97. ,101. , 

5 102.9,106.4,107,9,112.4,114.8,118.7,121.8,127.6,126.9,131.3, 

6 132.9,137.3,138.9,140.1,140.9,144.2,145. ,150.4,152. ,157.3, 

7 158.9,162.5,164.9,167.3,168.9,173. ,175. ,178.5,180.9,183.9, 

8 186.2,190.2,192.2,195.1, 197. ,200.6,204.4,207.2,209. ,209. , 

9 210. ,222. ,223. ,226. ,227. ,232. ,231. ,238./ 

: TABLE 1 FROM NYMMIK ET AL. 



DATA b/28*1.2/,to/28*1982.5/ 



TABLE 2 FROM NYMMIK ET AL. NOTE: D IN THE TABLE IS DD HERE 

data A/1. ,4. ,6.9,9. ,10.8,12. ,14. ,16. ,19. ,20.2,23. ,24.3,27. , 

* 28.1,31. ,32.1,35.4,39.9,39.1,40.1,44.9,47.9,50.9,52. ,54.9, 

* 55.8,58.9,58.7/ 

DATA DD/2.0E04,3.5E03, 1.7E01,1.6E01,5.1E01, 9.6E01,3.5E01, 

* 8.4E01,3.6EOO,1.5E01,4.2EOO,1.8E01,3.9EOO,1.2E01,1.0EOO, ' 

* 2.7EO0,1.2E0O,2.3E00,1.8E0O,2.6E0O,6.9E-01,2.5EO0,1.13EO0, 

* 2 . lEOO, 1 . 04E00, 9. 2E00, 8 . 7E-02, 4 . 5E-01/ 

DATA ALPHA/3., 3., 3. 4, 4. 5, 3. 9, 3. 1,3. 6, 3. 0,3. 8, 3. 1,3. 4, 3.0, 

* 3.2,3.0,4.0,3.4,4.5,4.5,4.2,3,2,3.6,3.6,3.3,3.3,3.0,3.1, 

* 4,0,3.2/ 

DATA GAMMA/2.75,2.75,2.70,2.90,3.00,2.75,2.90,2.70,3,00, 

* 2.75,2.90, 2.70,2.80,2.65,2.95,2.70,3.00,2.90,3.00,2.75, ' 

* 2,90,2.95,2.90,2.85,2.70,2.60,2.75,2.60/ 



Routine extended to 2 >28 using relative abundances from CREME, 
applied to the Fe spectrum calculated here: 

REAL RCREME(92) 

THE ELEMENTAL RATIOS HAVE BEEN EXTENDED TO URANIUM USING 
THE HEAO-3 DATA INTERPRETED WITH CAMERON'S ABUNDANCES AND 
THE RESULTS OF COSMIC RAY PROPAGATION CALCULATIONS 



c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 



(BINNS ET ^P^AP. J., VOL. 247, L115-L118,: 
A, G.W.CAMERON, HARVARD- SMITHSONIAN CENTER FOR ASTROPHYSICS 
PREPRINT SERIES NO. 1357, 1980, AND TSAO ET AL. , PROC . OF 
THE 17TH INTL. COSMIC RAY CONF . , VOL. 9, P130-33, PARIS, 1981). 
TABLE 7 IN CREME REPORT. 

Revised 6/19/92 by AJT, using latest combined HEAO-3/Ariel 
abundances, as reported by Binns et al. Ap.J 346,997-1009, 1989. 
NOTE: since these measurements cannot always resolve individual 

elements, the numbers here preserve the even-odd and 

intra-group ratios from CREME IV. 

DATA (RCREMEd) , 1 = 29, 92) / 
1 6.8E-4,8.8E-4,6.5E-5, 1.4E-4,8.9E-6, 5.2E-5, 

1 9.7e-6,2.7E-5,8.8E-6,2.9E-5,6.5E-6,1.6E-5,2.9E-6,8.1E-6,9.5E-7, 

2 3 .le-6, 1.6E-6,4.6E-6, 1.5E-6,4.0E-6,8.8E-7,4. 7E-6, 9.9E-7, 5.7E-6, 

3 l.le-6,2.7e-6,6.5E-7,6.7E-6,6.0E-7,1.8E-6,4.3E-7, 1.6E-6,1.9E-7, 

4 1.8e-6, 3.1e-7,1.4E-6,3.5E-7,1.4E-6,5.3E-7,8.8E-7,1.8E-7,8.9E-7, 

5 1.3e-7,8.1e-7,7.3E-8,8.1E-7,2.8E-7,1.2E-6,7.9E-7,l.SE-6,2.8E-7, 

6 4 . 9e-7, 1 . 5e-7, 1.4E-6, 7 .3E-8, 0 .,0.,0.,0.,0.,0., 8 .IE- 8, 0 . ,4 . 9E-8/ 



C- 
C 



m 



IZ=IZIN 

IF (IZ.GT.28) IZ=26 

IF (lENT.EQ.O) THEN 
IENT=1 

d(l)=0.012 
do i=2,28 

d(i) =d(l) *an(i) /float (i) 
end do 



; . 3 



c 
c 

c 
c 
c 
c 



CALCULATE PI 
PI=4.0*ATAN(1.0) 

OPEN FILE OF MONTHLY AVERAGE WOLF NUMBERS FROM MCKINNON AT NOAA 
AND READ THEM IN 



c use file starting in 1950 

C OPEN {UNIT=60, READONLY, SHARED, STATUS =' OLD' , 

C * FILE='CREME96 : WOLF. DAT' ) 

Stat = creme96_open('wolf .dat' , 'cr96tables' ,60, 'old' ) 



111 



IF (ydum .LT. 1950) THEN 
WRITE(*,111) 

FORMAT {IX, 'Warning, GCR results are unreliable before 1950') 
ENDIF 



C Modified read, where K is set to maximum array size. 

C this is 3600, allowing specification of 300 years. 



At present. 



DO K = 1,3600 



For dete^BKing bounds of Wolf number fil^^^If entered date 
outside of these bounds, the wolf numbers are extrapolated 
assuming a 22 year periodicity. 



MonthMax=I 

YearMax=FLOAT ( Jyear) + FLOAT (MonthMax-1) /12 . 0 

READ { 6 0 , 1 , END=2 ) JYEAR , I , WOLFTMP { K) 
J= (JYEAR-1749) +1 
W{I, J) =WOLFTMP(K) 

IF (K .EQ. 1) THEN 
MonthMin=I 

YearMin=FLOAT (Jyear) FLOAT (MonthMin-l) /12 . 0 
MonthMax=:I 

YearMax=FLOAT (Jyear) + FLOAT (MonthMax-1) /12 . 0 
ENDIF 
ENDDO 

FORMAT (14 , IX , 12 , F6 . 1) 
CONTINUE 

CLOSE (60) 



ENDIF IIENT = 0 OPTION 



COMPUTE THE BOUNDS OF THE WOLF NUMBER ARRAY. This update 
is to be used in smoothing algorithm, so that check if out of 
bounds. Also used by CheckDates routine, in order to handle 
transition in wolf number array at the center of each month, 
e.g. wolf number changes from month 6 (June) to month 7 (July) 
on the 15 June, as used in IB index. 

IYMIN=INT (YearMin) 

IBMIN= (IYMIN-1749) *12+12 . * (YearMin- lYMIN) + . 5+1 
IYMAX=INT (YearMax) 

IBMAX= ( IYMAX-1749) *12+12 . * (YearMax- lYMAX) + . 5+1 



2=IZ 

GCR MONTHLY FLUX=0 . 0 



CALCULATE DT (MONTH) FOR YEAR T 
T=YDUM 

IY=INT(T) i YDUM will now be used to pass the year of 

! interest to this fionction. R. Witt 6/22/95 

COMPUTE THE LOCATION, IB, OF THE WOLF NUMBER FOR TIME T IN 
THE W ARRAY 

IB= (IY-1749) *12+12 . * (T-IY) + . 5+1 



Routine ched^R.f T is within Wolf number boums 
T and IB assuming a periodicity of 22 years. 



If not, adjusts 



Note that period which crosses beginning year in wolf number data 
boundary has been handled as a special case in the DO 70 and DO 71 
loops below. 

CAll CheckDate (T, YearMin, Yearmax, IB, IBmin, IBmax) 

VERSION OF TO IN THE PAPER 

T0=1978.5 

IF{T.GE.1985.) T0=1976 
EN=EEZ 

CONVERT EN TO RIGIDITY IN GV, AS R 

R= (ANdZ) /Z) * (EN*EN+2 . *M0*EN) ** .5/1000 . 

CALCULATE DT (MONTH) FOR R IN YEAR T 

Tmin = 5.3/R**0.3 
SINE_TERM=sin{2.*PI* (t-tO) /22. ) 
IF(SINE_TERM.GE.O. ) SGN=1 . 
IF(SINE_TERM.LT.O. ) SGN=-1. 
DT = (Tmax+Tmin) /2 . + ( (Tmax-Tmin) /2 . ) *SGN* 
(ABS (SINE_TERM) ) ** (1 . /3 . ) 

CALCULATE THE SMOOTHED WOLF NUMBER, WS 

N=DT+0 . 5 
SUM=0. 

DO 70 K=1,N 

IF ((IB-K) .GE. IBMIN) SUM=SUM+K*WF (IB-K) 
Extrapolate backwards using 22 year solar cycle pattern 
IF ((IB-K) .LT. IBMIN) SUM=SUM+K* 
WF(IB-K+12*22) 

CONTINUE 

DO 71 K=N+1,2*N-1 

IF {(IB-K) .GE. IBMIN) SUM=SUM+ (2 *N-K) *WF { IB-K) 
Extrapolate backwards using 22 year repeating pattern 
IF ((IB-K) .LT. IBMIN) SUM=SUM+ (2 *N-K) * 
WF(IB-K+12*22) 

CONTINUE 

WS=SUM/ (N*N) 

COMPUTE THE MODULATION POTENTIAL 
R0=0. 375+3E-4*WS**1.44 5 
COMPUTE BETA 

BETA=SQRT(1- (EN/MO+l) ** (-2) ) 



COMMPUTE DELTA 



]^j^TO(IZ) ) /22. ) 



SINE=SIN(2.*Pr^r-T0(IZ) ) /22. ) 
IF(SINE.GE.O.) SGN=1.0 
IF(SINE.LT.O.) SGN=-1.0 
SINE=ABS(SINE) 

c Inserted to avoid floating underflows. 

ARG1=-BETA*R/D (IZ) 
ARG2=-BETA*R/R0 

IF (ABS(ARGl) .LE. l.OE-20) ARG1=0.0 

IF (ABS(ARG2) . LE . l.OE-20) ARG2 = 0.0 

DELTA=5.5*ABS(1-B(IZ) *EXP(ARG1) )+ 
* (1 . 13*BETA*R/R0) * {SGN*SINE** (1 . /3 . ) ) *EXP (ARG2) 

IF (ABS (DELTA) . LE . l.OE-20) DELTA=0.0 !also to avoid underflows 

C 

C COMPUTE THE FLUX 

C 

F= (DD(IZ)*BETA**ALPHA(IZ) ) /R**GAMMA ( IZ) 
F=F* (R/ (R+RO) ) **DELTA 

C 

C COMPUTE dR/dE 

Q c 

S dRdE= (AN(IZ) / (Z*1000. ) ) * (EN+MO) / ( (EN*EN+2 . *MO*EN) ** . 5) 

n c 

p C CONVERT FROM PER GV TO PER MeV/nuc 

SI c 

FLUX=F*dRdE 

j'l GCR_MONTHLY_FLUX=GCR_MONTHLY_FLUX+FLUX 

^ C Scale relative to Fe for Z > 28: 

IF ( IZIN . GT . 28 ) GCR_MONTHLY_FLUX=GCR_MONTHLY_FLUX*RCREME ( IZIN) 
\^ RETURN 
W END 



SUBROUTINE CheckDate (Year , YearMin, Yearmax, IB, IBmin, IBmax) 

C Routine checks if T is within Wolf number bounds. If not, adjusts 

C T to being in bounds assuming a 22.0 year periodicity. 

C 

C YearMin & YearMax are unused in this routine, but are included 

C as arguments for possible future use. 

IMPLICIT NONE 

REAL Year, YearMin, Yearmax 

INTEGER Ncycle, IBmin, IBmax, IB, IBlow, IBhigh, IBnew 

C fix wolf number range for extrapolating to be July 1970 to JUNE 1992 

C this algorithm assumes a 22 year periodicity. 

DATA IBlow, IBhigh/2659, 2922/ 



C 



IF ((IB .GE. IBmin) .AND. (IB .LE. IBmax)) THEN 



Dates are SBF , don't need to adjust YEAR o^^B 
RETURN 

ELSEIF (IB .GT. IBttiax) THEN 

IBnew= IBlow+MOD ( IB- IBhigh- 1 , IBhigh- IBlow+1 ) 

Ncycle= ( IB- IBhigh- 1) / ( IBhigh- IBlow+1) +1 

Year=Year-Ncycle*22 . 0 

IB=IBnew 
ELSEIF (IB .LT. IBmin) THEN 

IBnew= IBhigh-MOD ( IBlow- IB- 1 , IBhigh- IBlow+1) 

Ncycle= (IBlow- IB- 1) /(IBhigh- IBlow+1) +1 

Year=Year+Ncycle*22 . 0 

IB=IBnew 
ENDIF 

RETURN 
END 



SUBROUTi: 




>mag96 (Orblncl , Apogee , Perigee ,llKNodeLong , 
AscNodeDisp, PerigDisp, Zenith, Azimuth, UTtimelnit, 
Stormy, Shadow, PreCalcGTFs, IPreCalc, 
RigBins , TransFunc , Year , XLboiinds , ILbins ) 




# 
# 
# 



IMPLICIT NONE 



INTEGER J, Jmax, L, Ndays , NorbSteps , IPreCalc, Nrigs , NLvals 
PARAMETER (Ndays=7 , NorbSteps=200 , Nrigs=1001 , NLvals=10 ) 



Now REAL to properly handle omnidirectional averaging. 

Only the Earth's geometric shadow is included in the generic 

omnidirectional averaging at present. 

REAL MAT (Nrigs, NLvals ) ,TransInc 

INTEGER IDEX 

DATA TransInc/1 . 0/ 

REAL RigBins (Nrigs) , TransFunc (Nrigs, NLvals) 

LOGICAL Shadow, Stormy, PreCalcGTFs , Gridlnit , INIGRID 

Initial Orbital & lookout direction input parameters set 
in GTFDriverlnput 

REAL Orblncl, Apogee, Perigee, AscNodeLong, AscNodeDisp, PerigDisp 
REAL Zenith, Azimuth, C, Cgrid, Csupress , DeltaNymmik 
REAL UTtimelnit, UTtime,TimeLocal 
REAL Time, Period, Step 

Parameters along each orbital step 
REAL Zlat,Zlon,Alt 

INTEGER ILbins, ILbin, ICODE, NperLbin (NLvals) 
REAL Year, XLval,BBO,XLbounds (NLvals) ,XLinfinite 
PARAMETER (XLinf inite=l . OE+06 ) 

REAL Grid80Lval,RatioL 
LOGICAL UseLapprox 



Initializations 

DO L=l, NLvals 

NperLbin (L) =0 

DO J=l, Nrigs 
MAT(J,L) =0.0 
' ENDDO 
ENDDO 

Translnc=l . 0 

Choice of original geomagnetic storm option or pre -calculated GTF 
option. These are mutually exclusive now. Note that "Stormy" applies 
to updated Grid, and thus will be applied on top of the Nymmik 



correction for^^^h inclination orbits if that opcion is chosen. 



IF (PreCalcGTFs) THEN 

NOTE: The pre-calculated GTFs have not been divided into L-bins. 
This may be a useful option to include in future updates. 

CALL GetPreCalcGTF(IPreCalc,RigBins,TransFunc) 

RETURN ! could just use subsequent RETURN, since this IF statement 
! skips all lines before the subsequent RETURN 

ELSE ! calculate GTF if not using pre-calculated ones 

Initialize Orbit routine 

CALL Orbit (1, Period, ZLon, ZLat, Alt , Apogee, Perigee, Orblncl , 
AscNodeLong, AscNodeDisp, PerigDisp) 

Initialize cutoff grid. 

IF {.NOT. Gridlnit) GridInit=INIGRID 

Compute the total number of steps in "Ndays" days if we make 
"Norbsteps" steps per orbit.. Use 2 days and 200 steps per orbit 
presently. 

JMAX= INT (Ndays* NorbSteps*86400 . /PERIOD + 1.5) 
Compute the step size in seconds. 
STEP:= PERIOD/FLOAT (NorbSteps) 

Compute the vertical cutoff at the spacecraft 
position for every time step. 

DO J=1,JMAX 
time=FLOAT{j-l) *step 

CALL Orbit (2 , Time, ZLon, ZLat,Alt, Apogee, Perigee, Orblncl, 
AscNodeLong, AscNodeDisp, PerigDisp) 

Now calculate geomagnetic cutoff from the Grid. Perform before 
L- value calculation, and see similarity 

CALL GET_CUTOFF (ZLAT, ZLON, ALT, Azimuth, Zenith, C) 
Cgrid=C 

IF ( XLbounds(2) .LT. XLinfinite .OR. 

( XLbo\inds(2) .GE. XLinfinite .AND. 
XLbounds ( 1 ) . GT . 0.0 ) ) THEN 

CALL GridApproxLval ( Cg rid, XLbounds , ILbins, GridSOLval , 
UseLapprox) 

IF (UseLapprox) THEN 
XLval=Grid80Lval 



ELSE 




CALL GET_BLCOORDS (Year, Zlat , Zlon, Alt , XLval , BBO , ICODE) 
ENDIF 

IF (XLval .GT. 99999.0) XLval=99999 . 0 

CALL GetLbin (XLval , XLbounds , ILbins , ILbin) 

IF (ILbin .GE. 1 .AND. ILbin .LE. NLvals) 
NperLbin (ILbin) =NperLbin ( ILbin) +1 

ELSE 

If no L-bins are specified or 1 L-bin is specified 
and the lower bound is L = 0, use only the first 
element of the array. In this case, the following 
sum should equal JMAX once the stepping through the 
orbit is completed. 

ILbin=l 

NperLbin (Ilbin) -NperLbin (Ilbin) +1 
ENDIF 



CALL ConvertTime(time,UTtimeInit,UTtime,Zlon, Period, 
# TimeLocal) 



St C 



IF (Cgrid .GT. 0.0) THEN 

CALL Nymmik(C, TimeLocal, Del taNymmik) 
C=C/ (l+Del taNymmik) 

IF (Stormy) THEN 

C Now apply cutoff suppression during large magnetic storms, 

C as described by Adams, et al . (1981) . 

Csupress = . 54*EXP (-Cgrid/2 . 9) 

C=C-Csupress 

IF (C .LT. 0.) C=0.0 ! lowest cutoffs are defined to be 0 
^NDIF ! applying Stormy correction 

^^^^ ! checking that Cgrid (grid cutoff) > 0.0 

C 

C Histogram cutoffs in 0.02 GV steps. Since only allow vertical and 

C western cutoffs, all IDEX should be in bounds, since C_vert < 20 GV 

C Note that the transmission function is an integral spectra of 

C cutoffs < Rigidity. See CALCULATE_TRANS__FUNC for algorithm 

C which assigns rigidities for bins. 

IF (C .EQ. 0.0) THEN 

IDEX=1 
ELSE 

IDEX=INT(C*50. ) +2 
ENDIF 

C This is a correction for the earth's shadow on the spacecraft 




maoe 



C according to ^pie geometrical optics. Have mSe MAT real, and 

C apply to each point in calculation, in order to handle correction 

C properly for non-circular orbits. This routine has been designed 

C to always apply the Earth's shadow, although the technique will likely 

C be modified before 1997. 

C 

IF (Shadow) THEN 

Translnc= (1. -0.5* (1.- ( (6371 . 2+ALT) **2 . 
1 - (6371. 2 )**2.)**. 5/ (6371. 2+ALT) ) ) 

ENDIF ! applying Earth's shadow correction 

IF (ILbin .GE. 1 .AND. ILbin .LE. NLvals) 
& MAT (IDEX, ILbin) =MAT (IDEX, ILbin) +Translnc 



ENDDO 



! for number of orbital steps 



C 

C Now calculate transmission function, 

C 



CALL CALCULATE_TRANS_FUNC ( Jmax, MAT, RigBins , NperLbin, Trans Func) 
ENDIF rfor using either pre-calculated GTF or GRID-based options 



RETURN 
END 



C 



SUBROUTINE GET_CUTOFF ( ZLAT , ZLON , ALT , A2 , ZE , C ) 



C For input ZLAT, ZLON, ALT, A2, ZE, calculates cutoff C (in GV) 

C ZLON = geocentric longitude of spacecraft position (deg) 

C ZLAT = geocentric latitude of spacecraft position (deg) 

C ALT = spacecraft altitude (km) 

C AZ = azimuth of particle wrt spacecraft (deg) ■ 

C ZE = zenith angle of particle wrt ' spacecraft (deg) 
C 

C 

C Routine modified 3/5/90: 

C In JHA's original version of this coding, he first calculated the 

C vertical cutoff at the 4 grid corners at 20 km altitude, 

C re-scaled via Stormer theory to orbital altitude and orientation, 

C and then averaged the four. This procedure involved 5 calls 

C to subroutine FUNCTION STORMER. 



C In the modified coding, the 20 km vertical cutoffs are first averaged, 

C and then re-scaled via Stormer theory to orbital altitude and 

C orientation. This procedure involves only 2 calls to STORMER. It 

C . also gives a smoother transmission function 

C 

C 12/16/92, Fixed XORB bug, so that XORB is calculated for 

C all latitudes. RGRD is now a parameter 

C 

C 12/20/95, set cutoffs that are negative to 0.0. 
IMPLICIT NONE 



REAL ZLAT, ZLON, ALT, AZ,ZE,C 



REAL AZG,1^PrRGRD 



DATA AZG/0./,ZEG/0,/ 

PARAMETER (RGRr)=l . 0031392126 ) -equivalent to 6391.2/6371.2 

REAL CUTOFF (33, 72) ,CN,CS 
COMM0N/COT0FF8 0 /CUTOFF, CN, CS 

INTEGER ILO, lUP, JLO, JUP 
REAL ZI,ZJ,XORB,DI,DJ,SC,SG 
REAL Y1,Y2, Y3, Y4,CL 
REAL STORMER 



C COMPUTE THE TABULAR POSITION OF THE VERTICAL CUTOFF 

C 

C 

ZI=ZLAT/5.+17. 

ZJ=ZL0N/5.+l. 

ILO=INT(ZI) 

IUP=IL0+1 

JLO=INT{ZJ) 

IF{JLO.EQ.73) JLO=l 

atrp=jLO+i 

IF {JUP.EQ.73) JUP=1 

C 

C INTERPOLATE THE VERTICAL CUTOFF TO THE EXACT LOCATION 

C OF THE SPACECRAFT USING STORMER THEORY. 

XORB= (6371.2+ALT) /6371.2 

IF(ABS (ZLAT) .GE. 80. ) GO TO 100 
DI=ZI-FLOAT(ILO) 
D J= Z J - FLOAT ( JLO ) 

SC=STORMER { ZLAT , ZLON , XORB , AZ , ZE ) 
SG=STORMER(ZLAT, ZLON, RGRD, AZG, ZEG) 

Vertical cutoffs 
Y1=CUT0FF ( ILO , JLO ) 
Y2 =CUTOFF ( lUP , JLO ) 
Y3 =CUTOFF ( I LO , JUP ) 
Y4 -CUTOFF ( lUP , JUP ) 

C= (1 . -DI) * (1 . -DJ) *Y1+ (1 . -DI) *DJ*Y3+DI* (1 . -DJ) *Y2+DI*DJ*Y4 
C=SC*C/SG 



GO TO 200 

FOR ABS (LATITUDE) .GT.80 USE THE CUTOFFS AT THE POLE INSTEAD OF 
THE CUTOFFS AT FOUR NEARBY LOCATIONS. 

00 CONTINUE 

D J= Z J - FLOAT ( JLO ) 

SC=STORMER { ZLAT , ZLON, XORB , AZ , ZE ) 
SG= STORMER (ZLAT, ZLON, RGRD, AZG, ZEG) 
IF(ZLAT,LE. -80. )G0 TO 110 
DI=ZI-33. 

CL=DJ*CUTOFF (33 , JUP) + (1 . -DJ) *CUTOFF (33 , JLO) 



C= (DI*CN+(2. 



CD 12 . 




C=SC*C/SG 
GO TO 200 
110 CONTINUE 
DI=1. -21 

CL=DJ*CUTOFF ( 1 , JUP) + ( 1 . -DJ) *CUTOFF { 1 , JLO) 
C= (DI*CS+ (2 . -DI) *CL) /2 . 
C=SC*C/SG 
200 CONTINUE 

IF (C .LT. 0.) C=0.0 ladded 12-20-95 

RETURN 
END 



SUBROUTINE GetLbin (XLval , XLbounds , ILbins , ILbin) 
IMPLICIT NONE 

INTEGER ILbins, ILbin, NLvals,L 
PARAMETER (NLvals=10) 
REAL XLval , XLbounds (NLvals ) 
LOGICAL FindLbin 

No attempt is made to eliminate "unphysical" or "approximate" 
L- values using the ICODE returned from GET_BLCOORDS , since any 
analyses using L-values are likely to handle these locations 
"as is", i.e. with the calculated L- value. 



FindLbin=.TRUE. 

ILbin=0 

DO L=l, ILbins 
IF (FindLbin) THEN 

IF (L .LT. NLvals) THEN 

IF ( (XLval .GE. XLlDOunds (L) ) .AND. 
& (XLval .LT. XLbounds (L+1) ) ) THEN 



ILbin=L ■ 

FindLbin= . FALSE . 
ENDIF 

ELSE ! special handling of L=NLvals case 

IF (XLval .GE. XLbounds (L) } THEN 
ILbin=L 

FindLbin= . F7U:jSE . 
ENDIF 

ENDIF ! checking of each L-bin 
ENDIF !for FINDLbin logical 



ENDDO 



RETURN 
END 




c 

C My attempt to make this into a more modern FUNCTION, including the use 

C of IMPLICIT NONE. 5-7-96, PRB . 



REAL FUNCTION STORMER (GCLATD, GCLOND, RGC, AZ , ZE) 

C 

C WE DID NOT WRITE THIS SUBROUTINE. WE HAVE MADE NO CHANGES IN 

C IT IN 1984. 

C 

C 

C May 1996 comments and status, PRB. 
C 

C 1. Note that this FUNCTION uses the 1975 IGRF field plus drifts. 

C In principle, the 1980 IGRF/DGRF coefficients would be more 

C appropriate, since the STORMER corrections are applied to the 

C 1980 grid. In future years, we intend to replace the GRID results 

C with a 1990 grid, and will modify this routine accordingly. 

C 

C 2. The coefficients are also listed in inverted order, compared with 

C more recent tabulations, e.g. GOl is generally listed as GIO in more 

C recent tabulations. 

a c 

sQ C 3. This routine HAS NOT been converted to IMPLICIT NONE, due to the 

Q C historical nature of the coding, 

p C 

nj 

n IMPLICIT NONE 

2 REAL RED , EDLAT , AZM , 2 EM , GAMMA 

COMMON/KARL/RED, EDLAT, A2M,2EM, GAMMA 

;^ C Need to determine usage of DPEC{U), 5-7-96, PRB. 

REAL DPEC,U,ZEDRTL, ZRTL 

'-^ INTEGER JDATA,NOPT 

^ REAL PI,RAD,PI02,TW0PI-, SQRT3,DT 

REAL G01,G02,G11,G12,H11,H12,G22,H22,H0,H0SQ 

REAL ELO , ELI , EL2 , E , XEDFGC , YEDFGC , ZEDFGC , REDFGC 

REAL THETA, THETAD, PHI , PHID, CP, SP, ST, CT, CPCT, CPST, SPOT, SPST 

REAL RIER, RIKM, ERAD, THIRAD, THIDEG, PHIRAD, PHIDEG 

REAL XGMED , YGMED , ZGMED , ZDEDNP , RGC , XODNP , YODNP , ZODNP , DODNP 

REAL DIFLA, PHINOF, TNOF, SGCLATD , CGCLATD, GCLATD, SGCLOND, GCLOND 

REAL CGCLOND , XGC , YGC , ZGC , GCT , SGCT , CGCT , GCROT , SGCROT , CGCROT 

REAL XRL, YRL, ZRL , XEDRL , YEDRL , 2EDRL, XEDRTL, YEDRTL, XRTL, YRTL 

REAL XEDP , YEDP , ZEDP , XODNPR , YODNPR , ZODNPR , XODNPT , YODNPT , ZODNPT 

REAL ROTM , SROTM , CROTM , ROTMD , PLAZ , AZ , TLZE , ZE , S PLAZ , CPLAZ 

REAL STLZE , CTLZE , XLD , YLD , ZLD , CA , A , SA , ADEG , XLP , YLP , ZLP , CB , B , SB 

REAL BDEG , XLPP , YLPP , ZLPP , ZLDM , XLDM , YLDM , SMALL , PAZM 

REAL XEDl , YEDl , ZEDl , ZED2 , COSLDA 

C 



C THIS FUNCTION TRANSFORMS A GEOGRAPHIC LOCATION AND ARRIVAL 

■C DIRECTION INTO OFFSET DIPOLE COORDINATES, THEN COMPUTES THE 

C STORMER CUTOFF IN GV AND RETURNS THE RESULT. THE OFFSET DIPOLE 

C COORDINATES ARE AVAILABLE IN THE COMMON BLOCK /KARL/. 
C 
C 



GCLATD IS^RCENTRIC LATITUDE IN DEGREES 

GCIiONG IS GEOCENTRIC LONGITUDE IN DEGREES 

RGC IS RADIAL DISTANCE FROM GEOCENTER IN EARTH RADII 

AZ IS GEOGRAPHIC AZIMUTH 

ZE IS GEOGRAPHIC ZENITH 

RED IS RADIAL DISTANCE FROM OFFSET DIPOLE POSITION IN 

EARTH RADII 

EDLAT IS THE GEOMAGNETIC LATITUDE IN OFFSET DIPOLE COORDINATES 
AZM IS GEOMAGNETIC AZIMUTH IN OFFSET DIPOLE COORDINATES 
ZEM IS GEOMAGNETIC ZENITH IN OFFSET DIPOLE COORDINATES 
GAMMA IS GAMMA ANGLE MEASURED FROM MAGNETIC EAST 

DATA JDATA,NOPT/2*0/, PI , RAD, PI02 , XEDFGC, YEDFGC , ZEDFGC , CP, SP 
1 , ST, CPCT, CPST, SPOT, SPST, XGMED, YGMED, ZGMED/16 * - 8000 . / 
DATA SMALL/1. OE- 3 5/ 

In declaration section now, 5-96, PRB. 

DATA ERAD, THETAD, PHID, RIKM, THIDEG, PHlDEG/6371 . 2 , 
1 11.4354, -290.2392,450.2586,72.8278, 148.7753/ 



IF{JDATA.EQ.77) GO TO 10 

PI = ACOS(-l.O) 

RAD = 180.0/PI 

PI02 = PI/2.0 

TWOPI = PI*2 . 0 
NOPT = 0 

SQRT3 = SQRT(3.0) 

ENTER GEOMAGNETIC DATA, IGRF 1975 

SEE JGR, 81, 5163, 1976 

DT IS NUMBER OF YEARS SINCE 1975 



DT = 5 


.0 










GOl = 


-30186. 


0 


+ 


25 


.6*DT 


G02 = 


-1898. 


0 




24 


. 9*DT 


Gil = 


-2036. 


0 




10 


. 0*DT 


G12 = 


2997. 


0 


+ 


0 


. 7*DT 


Hll = 


5735. 


0 




10 


.2*DT 


H12 = 


-2124. 


0 




3 


. 0*DT 


G22 = 


1551. 


0 


+ 


4 


.3*DT 


H22 = 


-37. 


0 




18 


. 9*DT 



IF(NOPT.EQ.l) PRINT 1000, GOl, G02, Gil, G12 , G22, Hll, H12 , H22 

COMPUTE POSITION OF OFFSET DIPOLE 
HO = SQRT( G01*G01+G11*G11+H11*H11) 
HOSQ = HO*HO 

ELO = 2.0*G01*G02+(G11*G12+H11*H12)*SQRT3 

ELI = -G11*G02+ (G01*G12+G11*G22+H11*H22) *SQRT3 

EL2 = -H11*G02+ {G01*H12-H11*G22+G11*H22) *SQRT3 

E = (EL0*G01+EL1*G11+EL2*H11) *4.0*H0SQ 
E = (EL0*G01+EL1*G11+EL2*H11) / (4 . 0*HOSQ) 
IF(NOPT.EQ.l) PRINT 1011, ELO, ELI, EL2 , E, HO 
Oil FORMAT (IH , 8E15.5) 

XEDFGC = ERAD* (EL1-G11*E) / (3.0*H0SQ) 
XEDFGC = (EL1-G11*E) /(3.0*H0SQ) 

YEDFGC = ERAD*(EL2-H11*E)/(3.0*H0SQ) 
YEDFGC = (EL2-H11*E) /(3.0*H0SQ) 

ZEDFGC = ERAD* {EL0-G01*E) / (3 . 0*HOSQ) 
ZEDFGC = (EL0-G01*E)/(3.0*H0SQ) 

REDFGC = SQRT(XEDFGC*XEDFGC+YEDFGC*YEDFGC+ZEDFGC* ZEDFGC) 



IF(NOPT.EQ.l) 
FORMAT (IH , 



3001, XEDFGC, YEDFGC, ZEDFG^T REDFGC 

3X, 'XEDFGC, YEDFGC, ZEDFGC, REDFGC ) 




3001 



4F10.4, 



1000 FORMAT (IH , 10F13.5) 

1010 FORMAT (IHO, 8F15.5/1H ,8F15.5) 

THETA = THETAD/RAD 

PHI = PHID/RAD 

CP = COS (PHI) 

SP = SIN(PHI) 

ST = SIN (THETA) 

CT = COS (THETA) 

CPCT = CP*CT 

CPST = CP*ST 

SPOT = SP*CT 

SPST = SP*ST 

RIER = RIKM/ERAD 

THIRAD = THIDEG/RAD 

PHIRAD = PHIDEG/RAD 

IF (NOPT . EQ . 1) PRINT 1000 , RIKM, THIDEG, PHIDEG, RIER, THIRAD, PHIRAD 

XGMED = XEDFGC*CPCT -YEDFGC*SPCT -ZEDFGC*ST 

YGMED = XEDFGC*SP +YEDFGC*CP 

ZGMED = XEDFGC*CPST -YEDFGC*SPST +ZEDFGC*CT 

IF (NOPT. EQ.l) PRINT 3002, XGMED, YGMED, ZGMED 
3002 FORMATdH , 3F10.4, 13X, 'XGMED, YGMED, ZGMED') 

IF (NOPT. EQ.l) PRINT 1010, CP, SP, CT, ST, CPCT, CPST, SPOT, SPST 
Q JDATA = 77 

^ 10 CONTINUE 

pl C ITERATE TO FIND COORDINATES OF OFFSET NORTH DIPOLE AT ANY 

p C LATITUDE 

C FIRST GUESS FIND OFFSET NORTH DIPOLE AT DISTANCE RGC 

ZDEDNP = RGC 

100 XODNP = XGMED*CPCT + YGMED*SP + ZDEDNP*CPST 



DODNP = SQRT( XODNP* XODNP + YODNP*YODNP + ZODNP*ZODNP) 
DIFLA = DODNP - RGC 

IF(ABS(DIFLA) - l.OE-5) 120, 120, 110 
110 ZDEDNP = ZDEDNP - DIFLA 
4001 FORMAT (IH , 5X,'0DC 0, 0, 'F7.5, ' = GC X, Y, Z OF'3F8.5, 

1 ' DODNP ='F9.5,' DIF OF ' F9 . 6 , ' AT LOND LAT'FIO.4, F8 . 4 ) 
GO TO 100 
120 . CONTINUE 

PHINOF = ATAN2 (YODNP, XODNP) * RAD 
IF(PHINOF.LT.O.O) PHINOF = PHINOF + 360.0 
TNOF = -ACOS(ZODNP/DODNP)*RAD + 90.0 

IF (NOPT. EQ.l) PRINT 4 0 0 1 , ZDEDNP , XODNP , YODNP , ZODNP, DODNP, DIFLA, 
1 PHINOF, TNOF 

SGCLATD = SIN(GCLATD/RAD) 

CGCLATD = COS (GCLATD/RAD) 

SGCLOND = SIN(GCLOND/RAD) 

CGCLOND = COS (GCLOND/RAD) 
C GET GEOCENTRIC X Y Z COORDINATES 

XGC = RGC*CGCLATD*CGCLOND 

YGC = RGC*CGCLATD*SGCLOND 

ZGC = RGC* SGCLATD 

GCT = (90.0 - GCLATD)/RAD 

SGCT = SIN (GCT) 

CGCT = COS (GCT) 
C FIND X Y Z IN LOCAL COORDINATES OF X=0, Y=0, Z 

C THE LOCAL COORDINATE Z AXIS PASSES THRU P 

C THE LOCAL COORDINATE X,Z PLANE CONTAINS P 



YODNP 
ZODNP 



-XGMED*SPCT + YGMED*CP - ZDEDNP*SPST 
-XGMED*SP + ZDEDNP*CT 



GCROT = AT;ij^C,XGC) 

IF (NOPT.EQ.l) PRINT 2001, XGC, YGC, ZGC, GCROT 

001 FORMAT (IH , 4F10.4, 3X, 'XGC, YGC, ZGC, GCROT') 
SGCROT = SIN (GCROT) 

CGCROT = COS (GCROT) 

XRL = XGC*CGCROT*CGCT + YGC*SGCROT*CGCT - ZGC*SGCT 
YRL = -XGC*SGCROT + YGC*CGCROT 

ZRL = XGC*CGCROT*SGCT + YGC* SGCROT* SGCT + ZGC*CGCT 

002 FORMATdH , 3F10.4, 13X, 'XRL, YRL, ZRL') 
IF (NOPT.EQ.l) PRINT 2002, XRL, YRL, ZRL 

DETERMINE LOCATION OF OFFSET DIPOLE CENTER IN THESE SAME 

ROTATED LOCAL COORDINATES 
XEDRL = XEDFGC*CGCROT*CGCT + YEDFGC* SGCROT* CGCT - ZEDFGC*SGCT 
YEDRL = -XEDFGC* SGCROT + YEDFGC*CGCROT 

ZEDRL = XEDFGC*CGCROT*SGCT + YEDFGC* SGCROT* SGCT + ZEDFGC*CGCT 
IF (NOPT.EQ.l) PRINT 3003, XEDRL, YEDRL, ZEDRL 

003 FORMAT (IH , 3F10.4, 13X, ' XEDRLM YEDRL , ZEDRL') 
XEDRTL = XEDRL 

YEDRTL = YEDRL 
ZEDRTL = ZEDRL - ZRL 

IF (NOPT.EQ.l) PRINT 2 303, XEDRTL, YEDRTL, ZEDRTL 
303 FORMAT (IH , 3F10.4, 13X, 'XEDRTL, YEDRTK, ZEDRTL') 

TRANSLATE TO LOCAL COORDINATE SYSTEM WITH ORIGIN- AT SURFACE 
XRTL = XRL 
YRTL = YRL 
ZRTL =-ZRL 
XEDP = XRTL + XEDRL 
YEDP = YRTL + YEDRL 
ZEDP = ZRTL + ZEDRL 

RED = SQRT(XEDP*XEDP+YEDP*YEDP+ZEDP*ZEDP) 
102 FORMAT (IH , 3F10.4, 13X, 'XRTL, YRTL, ZRTL') 
IF (NOPT.EQ.l) PRINT 23 02, XRTL, YRTL, ZRTL 

EARTHS SURFACE AT A SPECIFIED ALTITUDE 
POSITION OF OFFSET NORTH DIPOLE IN LOCAL COORDINATE SYSTEM 
XODNPR= XODNP*CGCROT*CGCT + YODNP* SGCROT* CGCT - ZODNP*SGCT 
YODNPR= -XODNP*SGCROT + YODNP*CGCROT 

ZODNPR= XODNP*CGCROT*SGCT + YODNP* SGCROT* SGCT + ZODNP*CGCT 
XODNPT = XODNPR 
YODNPT = YODNPR 
ZODNPT = ZODNPR - ZRL 

IF (NOPT.EQ.l) PRINT 1103, XODNPT, YODNPT, ZODNPT 
03 FORMATdH ,10X, 'XODNPT =' FIO . 4 , 2X, ' YODNPT =' FIO . 4 , 2X, ' ZODNPT =' 
1 F10.4,3X, 'OFFSET N DIPOLE IN LOCAL COORDINATES') 
ROTM = ATAN2 (YODNPT, XODNPT) + PI 

FIND ANGLE FROM GEOGRAPHIC NORTH 

NEGATIVE - ROTATION FROM GEOGRAPHIC NP CLOCKWISE 
POSITIVE - ROTATION FROM GEOGRAPHIC NP CCW 

SROTM = SIN (ROTM) 

CROTM = COS (ROTM) 

ROTMD = ROTM* RAD 

27 FORMAT (IH , F15.5, 3X, ' ROTM IN DEGREES MEASURED CCW SO -X 
1 WILL POINT TOWARD OFFSET NORTH DIPOLE AXIS') 
IF(NOPT.EQ.l) PRINT 2327, ROTMD 

FIND COMPONENTS OF UNIT VECTOR AT ARBITARY AZIMUTH AND ZENITH 
PLAZ = -AZ/RAD + PI 
TLZE = ZE/RAD 
SPLAZ = SIN (PLAZ) 
CPLAZ = COS (PLAZ) 
STLZE = SIN (TLZE) 
CTLZE = COS (TLZE) 




XLD = STLZE*cfj^ 

YLD = STI,ZE*SPLAZ 
ZLD = CTLZE 

IF (NOPT.EQ.l) PRINT 2005, XLD, YLD, ZLD, AZ, ZE 

FORMAT (IH , 5F10.4, 3X, 'UNIT VECTOR COMPOENTS AT AZ t ZE' ) 

FIND COMPONENTS OF UNIT VECTOR IN DIPOLE RADIAL COORDINATES 



ROTATE AROUND Y AXIS SO -Z AXIS PASSES THROUGH XED, 0, ZED 
NEW VECTOR IS VA = ZRTL + ZEDRTK + XEDRTL 

ANGLE BETWEEN VECTOR FROM POINT LOCAL ORIGIN TO GEOCENTER 
AND VECTOR FROM POINT LOCAL ORIGIN TO XED, 0, ZED 

JIM LANGWORTHY'S FIX 
********************* *************** ********* 

CA=DPEC { XEDRTL , ZEDRTL , ZRTL ) 

CA = ZRTL* ZEDRTL/ (ABS (ZRTL) *SQRT{ ZEDRTL* ZEDRTL + XEDRTL*XEDRTL) ) 
A = ACOS(CA) 

IF (XEDRTL. GT. 0.0) A = -A 
SA = SIN (A) 
ADEG = A*RAD 

IF (NOPT.EQ.l) PRINT 1000, CA, A, SA, ADEG 

XLP = XLD*CA + ZLD*SA 

YLP = YLD 

ZLP ==-XLD*SA + ZLD*CA 

IF(NOPT.EQ.l) PRINT 5001, XLP, YLP, ZLP 

FORMATdH , 3F10.4, 13X, 'XLP, YLP, ZLP ') 

ROTATE AROUND X PRIME AXIS SO -Z PASSES THROUGH XED, YED, ZED 
CB=DPEC (YEDRTL, ZEDRTL, ZRTL) 

CB = ZRTL*ZEDRTL/ (ABS (ZRTL) *SQRT(ZEDRTL*ZEDRTL + YEDRTL * YEDRTL ) ) 
B = ACOS(CB) 

IF ( YEDRTL. GT. 0.0) B = -B 
SB = SIN(B) 
BDEG = B*RAD 

IF (NOPT.EQ.l) PRINT 1000, CB, B, SB, BDEG 
XLPP = XLP 

YLPP = YLP*CB + ZLP*SB 
ZLPP =-YLP*SB + ZLP*CB 

IF (NOPT.EQ.l) PRINT 5002, XLPP, YLPP, ZLPP 
FORMATdH , 3F10.4, 13X,'XLPP, YLPP, ZLPP ') 

ROTATE AROUND ZPP AXIS SO -X AXIS PASSES THROUGH NORTH 

OFFSET DIPOLE AXIS 

ZLDM = ZLPP 

XLDM = XLPP*CROTM + YLPP*SROTM 
XLDM = XLPP*CROTM -YLPP*SROTM 
YLDM =-XLPP*SROTM + YLPP*CROTM 
YLDM = XLPP*SROTM + YLPP*CROTM 

IF (NOPT.EQ.l) PRINT 1101, XLD, YLD, ZLD, XLDM, YLDM, ZLDM 
FORMAT (IH , 'UNIT VECTOR IN LOCAL COORDINATES ', 3F8.5,5X, 
1 'UNIT VECTOR IN LOCAL MAGNETIC COORDINATES^', 3F10.5) 

FIND AZUMITH ANGLE OF UNIT VECTOR IN LOCAL DIPOLAR RADIAL COOR 
IF ( (ABS (YLDM) .GT. SMALL) .OR. (ABS (XLDM) .GT. SMALL) ) GO TO 1102 
PAZM=0.0 
GO TO 1104 

PAZM = ATAN2 (YLDM, XLDM) 
AZM = (PI - PAZM) *RAD 

IF (AZM.GT. 360.0) AZM = AZM - 360.0 
ZEM = ACOS (ZLDM) * RAD 

FIND GAMMA ANGLE 
GAMMA = ACOS (YLDM) * RAD 



3^^^ET DIPOLE CCX)RDINATES 



TRANSFORM TO^ 
XED1=XGC-XEDFGC 
YEDl = YGC - YEDFGC 
ZED1=2GC-ZEDFGC 

FIND THE Z COORDINATE IN OFFSET DIPOLE COORDINATES 

2ED2 =XED1 *CPST - YEDl * S PST+ ZEDl * CT 

FIND THE GEOMAGNETIC LATITUDE 

EDLAT=RAD* (PI02-AC0S (ZED2/RED) ) 

COSLDA=C0S (EDLAT/RAD) 

STORMER=60 . *C0SLDA**4 . / 

(RED*RED* (1 . +SQRT(1 . -C0SLDA**3 . *YLDM) ) **2) 

RETURN 
END 



REAL FUNCTION DPEC (U, ZEDRTL, ZRTL) 

IMPLICIT NONE 
REAL U, ZEDRTL, 2RTL 



DPEC=SIGN(1./SNGL{DSQRT{1D0+DBLE( (U/ZEDRTL) **2) ) ) , ZRTL* ZEDRTL) 

RETURN 
END 



SUBROUTINE GridApproxLval (Cgrid, XLbounds , ILbins , GridSOLval , 
& UseLapprox) 
IMPLICIT NONE 

REAL XLinf ini te , Rat ioCheck , Grids OLval , Cgrid 
INTEGER ILmax,NLvals, L, ILbins 

PARAMETER (XLinf inite=l . OE+06 , NLvals=10 , Rat ioCheck=l . 2 ) 

REAL XLboiinds (NLvals) 
LOGICAL UseLapprox 



Grid80Lval=XLinf inite 

IF (Cgrid .GT. 0.) Grid80Lval=SQRT (14 . 5/Cgrid) 
ILmax = ILbins 
UseLapprox= . FALSE . 

IF (GridSOLval .GT. RatioCheck*XLbounds (ILmax) ) THEN 

UseLapprox= . TRUE . 
ELSE 

DO L=2 , ILmax 

IF ( (GridSOLval .GT. RatioCheck*XLbounds (L-l) ) .AND. 
& (GridSOLval .LT. XLbounds (L) /RatioCheck) ) THEN 

UseLapprox= . TRUE . 



ENDIF 
ENDDO 
ENDIF 

RETURN 
END 



SUBROUTINE LCOORDS (YEAR, LATI , LONGI , HEIG^^^L, BBO , ICODE) 

C Subroutine adapted from BILCAL by AJT for calculating 

C geomagnetic coordinates B/BO (=BBO) and Mcllwain L (=XL) 

C 12/9/92 
C 

C Modified 11-17-97: add IMPLICIT NONE & variable- type declarations 
C 

C Inputs : 

C YEAR = year (eg., 1987.63) for field initialization, etc. 

C LiATI, LONGI = geodetic latitude and (east) longitude (degrees) 

C HEIGHT = geodetic altitude (km above sea level) 

C Outputs: 

C XL = Mcllwain L parameter 

C BBO = B/BO 

C ICODE = return code: 1=0K; 3=approx result; 

C 2=one of the conjugate mirror points is 

C unphysical. 

IMPLICIT NONE 

REAL YEAR, LATI, LONGI, HEIGHT, XL, BBO 
INTEGER ICODE 
LOGICAL VAL 

Q REAL DIMO,BNORTH, BEAST, BDOWN, BABS, BABl , BEQU, BDEL, BEQ, RRO 

C Initialize field coefficients (if needed), get dipole moment 

p. CALL FELDCOF(YEAR,DIMO) 

51 C Get local field strength (BABS) 

.1^ CALL FELDG (LATI , LONGI , HEIGHT, BNORTH, BEAST, BDOWN, BABS) 

rl C Calculate Mcllwain L and set ICODE flag. 

^ CALL SHELLG(LATI, LONGI, HEIGHT, DIMO, XL, ICODE, BABl) 

^ IFdABS (ICODE) .GT. 9) IC0DE=2 

^ C Calculate B/BO 

H BEQU=DIMO/ (XL*XL*XL) 

riJ IF (ICODE. EQ. 1) THEN 

yj BDEL=l.E-3 

M CALL FINDBO (0.05, BDEL, VAL, BEQ, RRO) 

IF (VAL) BEQU=BEQ 

Si ENDIF 

BB0=BABS/BEQU 

IF(BB0.GT. 9999. 999) BB0=9999.999 
C Done 

RETURN 
END 



SUBROUTINE GE1WHECK_C0NTR0L ( FILE_CHECK) 
C 

C Sets logical to direct various file-checking functions in the 

C CREME96 software (CHECK_FILE, CHECK_NAME_CONFLICT, CHECK_OUTPUT_FILE) 

C 

C Recommended usage: logical FILE_CHECK= . true . 

C for VAX & PC stand-alone versions of the code 

C 

C logical FILE_CHECK= . false . 

C for the PC/WWW version. 



C 



IMPLICIT NONE 
LOGICAL FILE_CHECK 

FILE_CHECK= . true . 

RETURN 
END 



REAL FUNCT 



(ET_CREME96_FLUX (IZ, EN, YEAR, IMODE 




I TRANS) 



C 

C 

C 
C 

Q 
n 



Returns particle flux from CREME96 particle environment model. 

IMPLICIT NONE 

INTEGER*4 I Z, IMODE, I TRANS 

REAL* 4 EN, YEAR, FLUX 

REAL*4 CRF96 , CUT96 , GET_TRAPPED_PROTONS , GET_TRAPPED_IONS 

GET_CREME96_FLUX=0 . 0 

IF (EN.LT.1.0) RETURN 

IF (IZ.LT.l .or. IZ.GT.92) RETURN 

IF (ITRANS.EQ.O) THEN 

Fluxes outside of the magnetosphere 

FLUX=CRF96 (IZ, EN, YEAR, IMODE) 
ELSEIF (ITRANS.EQ. 1) THEN 

Non- trapped fluxes inside the magnetosphre 

FLUX=CUT96 {IZ,EN, YEAR, IMODE) 
ELSEIF (ITRANS.EQ. 2) THEN 

Non- trapped & Trapped fluxes inside the magnetosphere 

FLUX=:CUT96 (IZ, EN, YEAR, IMODE) 

Function names modified 12-10-97 by AJT 

IF (IZ.EQ.l) FLUX=FLUX+GET_TRAPPED_PROTONS (EN) 

IF (IZ.GT.l) FLUX=FLUX+GET_TRAPPED_IONS (IZ,EN) 
ENDIF 

GET_CREME 9 6_FLUX = FLUX 

RETURN 
END 





SUBROUTINE GET_(^!eME96_FLUX_MODEL ( INFILE , MODEL_TYPE) 

Decodes header of CREME96 flux file to determine type of flux model. 
Information is used in converting solar particle results from average 
rates to event -accumulated numbers. 

IMPLICIT NONE 
CHARACTER*80 INFILE, ILINE 
CHARACTER* 3 SUFFIX, IMODEL 

INTEGER*4 MODEL_TYPE , ILONG, ILONGl , IL0NG2 , 
& IVER, J, NHEADER, STAT, CREME96_OPEN 

MODEL_TYPE=0 

ILONG= INDEX (inFILE, ' . ' ) 
SUFFIX=INFILE {ILONG+1 : ILONG+3) 
CALL CAPITALIZE_STRING (SUFFIX, 3) 

IF { SUFFIX. ne. 'FLX' .and. SUFFIX . ne TFX ' .and. 
& SUFFIX. ne. 'LET' .and. SUFFIX . ne .' DLT' ) RETURN 



Now open file and decode header: 

CALL CHECK_CREME96_VERSION (INFILE, IVER) 

IF (IVER. GE. 102) THEN 

Stat = creme96_open (inf ile, 'user' , 10, 'old' ) 
IF (STAT.EQ.O) THEN 
READ (10,*) NHEADER 
DO J=l, NHEADER 

READ(10,110) ILINE 

FORMAT (A80) 

IMODEL= ' 

IL0NG1 = INDEX (ILINE, '%IMODE =') 

IF (ILONGl .NE. 0) IMODEL=ILINE ( ILONGl + 8 : ILONGl + 10) 
IL0NG2 = INDEX (ILINE, ' %IMODE =' } 

IF (IL0NG2 .NE. 0) IM0DEL= ILINE ( ILONG2+10 : ILONG2+12) 
IF (IMODEL.NE.' ') THEN 



99 



WRITE (6, 9999) IMODEL 

FORMAT (' IMODEL=' , A3 , ) 

DECODE (3,100, IMODEL ) MODEL_TYPE 

FORMAT (13) 

RETURN 



ENDIF 
ENDDO 
ENDIF 



ENDIF 



RETURN 
END 



c 
c 
c 




SUBROUTINE GET5BRmE96_VERSION ( IVER) 

Sets version number of CREME96 software, for record keeping purposes 

IMPLICIT NONE 
INTEGER*4 IVER 

C Modified 7/29/96: Version 1.01 

C Modified 8/19/96 Version 1.02/ more extensive output file headers 

C Modified 9/14/96 Version 1.03: default energy limits; 
^ energy limits in LET calculations 

C extended tables for Z > 28 added. 

C Modified 9/25/96 Version 1.04: ACR charge-state distributions added 
IVER=104 



RETURN 
END 



REAL FUNCT 



IET_GTF (RIGIDITY) 



Evaluates orbit -averaged geomagnetic transmission function 
(previously calculated by GEOMAG96 and loaded into COMMON/GTFDAT 
by LOAD_GTF) at rigidity RIGIDITY (in GV) . 

IMPLICIT NONE 

INTEGER*4 NGTF, IGTF , I , ISAV 
REAL*4 R,GTF, P, RIGIDITY 
PARAMETER (NGTF=1001) 

COMMON/GTFDAT/ IGTF, R (NGTF) , GTF (NGTF) 

LOOK UP THE TABULATED MAGNETIC RIGIDITY JUST ABOVE RIGID 

GET_GTF=0. 0 

IF (IGTF.LE.O) RETURN 

P=RIGIDITY 

GET_GTF=GTF ( IGTF) 

IF (P.GT.R(IGTF) ) RETURN 

GET_GTF=0 . 0 

IF' (P.LT.R(l) ) RETURN 

DO 2 1=2, IGTF 

IF(P.GT.R(I) ) GOTO 2 

ISAV=I 

GOTO 3 

CONTINUE 

INTERPOLATE THE TRANSMISSION FACTOR (AVERAGED FOR THE ORBIT) . 

GET_GTF=GTF { ISAV- 1 ) + 

{GTF (ISAV) -GTF ( ISAV- 1) ) * (P-R(ISAV-l) ) / (R(ISAV) -R{ISAV-1) ) 



RETURN 
END 



SUBROUTINE ^F_HI_XS_INPUTS (DEVICE_LABEL, XM, YM, ZM, FUNNELM, NBITS , 

IPARAM, PARAMS,XSECT FILE) 

C 
C 

C Interactive dialogue to get necessary cross- sectioninput parameters 

C for heavy- ion upsets: 

C 

C Written by: Allan J. Tylka 

C Code 7654 

C Naval Research Laboratory 

C Washington, DC 20375-5352 

C tylka@crs2 .nrl .navy.mil 
C 



C- 
C 



IMPLICIT NONE 

CHARACTER* 80 XSECT_FILE 

CHARACTER* 40 DEVICE_LABEL 

REAL*4 XM, YM, ZM, FUNNELM, PARAMS, NBITS 

INTEGER*4 IPARAM 

DIMENSION PARAMS(4) 

INTEGER*4 IFILETYPE , lACCEPT 

INTEGER*4 lERR 

DATA IERR/0/ 

WRITE (6, 1210) 

1210 FORMATdx,' *** NOTE *** : At any point in the following' 

& ' dialogue, you can go back and' 

& /,lx,' change a parameter by entering -l for the', 

& ' presently requested information.', 

& //Ix,' Repeated -1 values can be used to scroll back' 

& 'to (almost) anywhere in the input menu.') 

105 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1215) 

1215 FORMAT{/,lx, ' Enter device label and/or comments', 
& ' (40 characters max) for record-keeping:') 

READ (*, 1218, ERR=105, IOSTAT=IERR) DEVICE_LABEL 
1218 FORMAT (A40) 



IF (DEVICE_LABEL(1:2) .EQ. ' -1' ) RETURN 
WRITE (6,1219) DEVICE_LABEL 
1219 FORMATdx,' Devi ce /Comment : ' ,A40) 



CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1200) 

FORMAT (/,' This program calculates the heavy- ion SEU rate', 
' using the RPP method.', 
/,' Enter the dimensions of the', 

' bit sensitive volume: {X,Y,Z; in microns)') 

READ (* , * , ERR=1185 , IOSTAT=IERR) XM, YM, ZM 

IF (XM.LE.-l.O .or. YM.LE.-l.O .or. ZM.LE.-l.O) GOTO 105 
WRITE(6,1220) XM,YM,ZM 

FORMAT (' Sensitive volume dimensions = ', 

F8.2,' X ',F8.2,' X ',F8.2,' microns') 



1185 



1200 



1195 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE(6,2200) 
2200 FORMAT (' Enter funnel length (microns): ') 

READ(*,*,ERR=1195, IOSTAT=IERR) FUNNELM 

IF (FUNNELM. LE. -1.0) GOTO 1185 

WRITE (6, 2220) FUNNELM 
2220 FORMAT (' Funnel length = ' , F8 . 2 , ' microns.') 



1225 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1300) 

1300 FORMAT{//,' This code supports several methods for specifying', 
& ' the SEU cross-section:', 

& /,' METHOD = 0: a file containing a two-column table,' 

& /, ' METHOD = 1: Bendel 1-parameter fit ', 

& /,' METHOD = 2: Bendel 2 -parameter fit ', 

& /,' METHOD = 3: NOT CURRENTLY USED', 

& /,' METHOD = 4: Weibull fit ', 

& /,' METHOD = 5: Critical charge (in pC) ' , 

& //,' Specify METHOD (0,1,2,4, or 5): ') 

READ{*, *,ERR=1225, IOSTAT=IERR) IPARAM 
IF (IPARAM. LE. -1) GOTO 1195 

IF (IPARAM. EQ. 0) THEN 
1395 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1400) 

1400 FORMATC SEU cross-section from input table file:', 

& /,' This table must have a two-column format with :', 

& /,llx, ' column 1 containing LET (in MeV-cm2 /milligram) ' , 
& /,7x,' and column 2 containing SEU cross-section', 
& ' (in sq. microns/bit) ' , 

St /,1k,' and be ordered according to increasing LET.', 

& /,' The file containing the table must already exist in', 

& ' your current USER area and ' , 

Sc be called something .XSD (ie., have XSD for the extension).' 

& /,' Enter name of the cross-section file: ') 

READ(*, 1,ERR=1395, IOSTAT=IERR) XSECT_FILE 
1 FORMAT (ABO) 

IF (XSECT_FILE(1:2) .EQ. ' -1' ) GOTO 1225 

WRITE (6, 1410) XSECT_FILE 
1410 FORMATdx,' Input Heavy-Ion Cross-Section File = ',/,lx,A80) 

IFILETYPE=8 

CALL CHECK_FILE (IFILETYPE,XSECT_FILE, lACCEPT) 
IF ( IACCEPT . NE . 0 ) GOTO 13 95 

ELSEIF (IPARAM. EQ.l) THEN 
1495 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6,1500) 

1500 FORMATC Bendel 1-parameter fit to the cross-section: ', 

Sc /,' NOTE: Your fit parameters must specify heavy- ion' 

Sc /,' SEU cross-section (in sq. microns/bit) vs.', 

Sc ' LET (in MeV-cm2 /milligram) : ' 

Sc /,' Enter Bendel -1 parameter value: ') 

READ(*, *,ERR=1495, IOSTAT=IERR) PARAMS (1) 




IF (PAH^pil) .LE. -1. ) GOTO 1225 
WRITE{6, 1510) PARAMS(l) 
1510 FORMAT (' Bendel-1 parameter = ',E13.6) 

ELSEIF (IPARAM.EQ.2) THEN 
1595 CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE (6, 1600) 

1600 FORMATC Bendel 2-parameter fit to the cross-section: 

& /, ' NOTE: Your fit parameters must specify heavy-ion' 

Sc I,* SEU cross-section (in sq. microns/bit) vs.', 

& ' LET (in MeV-cm2/milligram) : ' 

& /, ' Enter Bendel A & B parameter values: ') 

READ { * , * , ERR=1 5 9 5 , IOSTAT= lERR) PARAMS ( 1 ) , PARAMS ( 2 ) 
IF (PARAMS (1) .LE. -1. .or. PARAMS (2) . LE . -1 . ) GOTO 1225 
WRITE (6, 1610) PARAMS (1) , PARAMS (2) 
1610 FORMATC Bendel parameters A,B = ',2E13.6) 

ELSEIF (IPARAM.EQ.3 .or. IPARAM.LT. 0 .or. IPARAM.GT.5) THEN 
1695 CONTINUE 

WRITE(6,1700) 

1700 FORMATC ILLEGAL CROSS-SECTION SPECIFICATION CODE. 

& /,' Please try again.') 

GOTO 1225 



■-^n ELSEIF (IPARAM.EQ.4) THEN 

□ 1795 CONTINUE 

p CALL RETRY_INPUT(IERR) 

WRITE (6, 1800) 

1800 FORMATC Weibull fit to the cross-section: 

& /,' NOTE: Your fit parameters must specify heavy-ion' 

^ //' SEU cross -section (in sq. microns/bit) vs.', 

I & ' LET (in MeV-cm2/milligram) : ') 

WRITE (6, 1810) 

1810 FORMATC Enter ONSET parameter (in MeV-cm2 /milligram) : ') 

J"! READ(*,*,ERR=1795, IOSTAT=IERR) PARAMS (1) 

IF (PARAMS (1) .LE. -1. ) GOTO 1225 
1815 CONTINUE 
^ CALL RETRY_INPUT.(IERR) 

^ WRITE (6, 1820) 

1820 FORMATC Enter WIDTH parameter (in MeV-cm2/milligram) : ') 

READ(*, *,ERR=1815,IOSTAT=IERR) PARAMS(2) 
IF (PARAMS (2) .LE. -1. ) GOTO 1795 
1825 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1830) 

1830 FORMATC Enter POWER parameter (dimensionless exponent): ') 

READ{*,*,ERR=1825,IOSTAT=IERR) PARAMS (3) 

IF (PARAMS (3) .LE. -1. ) GOTO 1815 
1835 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE (6, 1840) 

IF (XM.GT.O.O .and. YM.GT.0.0) WRITE (6 , 1841 ) 

1840 FORMATC Enter cross-section plateau value', 
& ' (in sq. microns/bit).') 

1841 FORMATC (If 0, calculation will use surface area (xy) of, 
& ' the RPP sensitive volume.)') 

READ(*, *,ERR=183 5, IOSTAT=IERR) PARAMS (4) 

IF (PARAMS (4) .LE.-l. ) GOTO 1825 

IF (PARAMS (4) .LE.O. ) PARAMS (4 ) =XM*YM 



WRITE (6, 18^ PARAMS(l) ,PARAMS(2) , PARAMS ( 3 )T^ARAMS ( 4 ) 
1850 FORMAT (' Weibull fit parameters: 

& /,5x,' ONSET = ',F9.3,' MeV-cm2/milligram' , 

& /,5x, ' WIDTH = ',F9.3,' MeV-cm2/Tnilligram' , 

& /,5x,' POWER = ',F9.3,' (dimensionless) ' , 

& /,5x,' PLATEAU- ' , F9 . 3 , ' square microns /bit' ) 



1895 



1900 



Sc 
Sc 
Sc 

& 
★ 



1905 



1910 



1915 



O 1920 



1930 



ELSEIF (IPARAM.EQ. 5) THEN 
CONTINUE 
WRITE (6, 1900) 

FORMAT (' Cross-section given as step function in critical' 
' charge . ' , 

/,' NOTE: in general this method does NOT' 

' give accurate results for space', 

applications, but it may be useful for' 

' order-of -magnitude estimates by chip',/, 
CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6, 1910) 

FORMAT {' Enter critical charge (in picocoloubs) : 
READ(*, *,ERR=1905, IOSTAT=IERR) PARAMS (1) 
IF (PARAMS (1) .LE. -1. ) GOTO 1225 
CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE (6, 1920) 

IF (XM.GT.0.0 .and. YM.GT.0.0) WRITE (6 , 1841) 

FORMATC Enter cross-section (in square microns/bit) : ' ) 

READ ( * , * , ERR=1915 , IOSTAT=IERR) PARAMS (2 } 

IF (PARAMS (2) .LE.-l.) GOTO 1905 

IF (PARAMS (2) .LE. 0. ) PARAMS (2 ) =XM*YM 

WRITE (6, 1930) PARAMS ( 1 ), PARAMS ( 2 ) 

FORMATC Critical charge = ',E13.5,' picocoloumbs ' , 

/,' Cross-Section = ',E13.5,' square microns/bit' ) 



designers . ' ) 



) 



ENDIF 



1995 



2000 



CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6,2000) 

FORMATC Finally, specify number of bits per device: ') 
READ{*, *,ERR=1995, IOSTAT=IERR) NBITS 
IF (NBITS. EQ. -1) THEN 

GOTO 14 95 
GOTO 1595 
GOTO 16 95 
GOTO 1835 
GOTO 1915 



IF 
IF 
IF 
ENDIF 



IF (IPARAM.EQ. 1) 
IF (IPARAM.EQ. 2) 
(IPARAM.EQ. 3} 
(IPARAM.EQ. 4) 
(IPARAM.EQ, 5) 



WRITE (6,2010) NBITS 
2010 FORMAT(lx,E13.5, ' bits per device.') 



RETURN 
END 



SUBROUTINE G4^iOTON_XS_INPUTS (DEVICE^LABEL, l^^S , 

IPARAM,PARAMS,XSECT FILE) 



C 
C 

C Generates interactive dialogue to get necessary input parameters 

C for proton- induced SEU rate: 

C 

C Written by: Allan J. Tylka 

C Code 7654 

C Naval Research Laboratory 

C Washington, DC 20375-5352 

C tylka®crs2 .nrl .navy.mil 

C 

C Last update: 20 August 1996 

C 

C 

C 

IMPLICIT NONE 

CHARACTER* 8 0 XSECT_FILE 

CHARACTER* 40 DEVICE_LABEL 

REAL*4 PARAMS,NBITS 

INTEGER*4 IPARAM 

DIMENSION PARAMS(4) 

INTEGER*4 IFILETYPE , lACCEPT, lERR 

DATA IERR/0/ 

WRITE (6, 1210) 

1210 FORMATdx,' *** NOTE ***: At any point in the following' 

& ' dialogue, you can go back and' 

Sc //Ix,' change a parameter by entering -l for the', 

^ ' presently requested information.', 

& /,lx,' Repeated -1 values can be used to scroll back', 

& ' to (almost) anywhere in the input menu.'.) 

105 CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE (6, 1215) 

1215 FORMAT(/,ix, ' Enter device label and/or comments', 
& ' (40 characters max) for record-keeping:') 

READ {* , 1218 , ERR=105 , IOSTAT=IERR) DEVICE_LABEL 

1218 FORMAT (A40) 

IF (DEVICE_LABEL(1;2) .EQ. ' -1' ) RETURN 
WRITE (6, 1219) DEVICE_LABEL 

1219 FORMATdx, ' Devi ce /Comment : ' ,A40) 



1295 CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE (6, 1300) 

1300 FORMATi This code supports several methods for specifying', 

& ' the SEU cross-section:', 

& /,' METHOD = 0: a file containing a two-column table,' 

& /,' METHOD = 1: Bendel 1-parameter f it ' , 

& /,' METHOD = 2: Bendel 2-parameter fit ', 

& /,' METHOD = 3: NOT CURRENTLY USED', 

& /,' METHOD = 4: Weibull fit ', 

& //,' Specify METHOD (0,1,2, or 4) : ') 




ril 
1X1 



READ(*,*,E^pr95,IOSTAT=IERR) IPARAM 
IF ( IPARAM ^T-l) GOTO 105 
IF ( IPARAM. EQ.O) THEN 
13 95 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE (6, 1400) 

1400 FORMATC SEU cross- section from input table file:', 

& This table must have a two-column format with 

& /,llx, ' column 1 containing proton energy (in MeV) ' , 
& /i7x,' and column 2 containing SEU cross-section', 
& ' (in 10**-12 cm2/bit) ' , 

& A7x,' and be ordered according to increasing proton energy ' 
& /, ' The file containing the table must already exist in' 
Sc ' your current USER area and ' , 

& A I be called something . XSD (ie., have XSD for the extension) 
& /,' Enter name of the cross-section file: ') 

READ(*,l,ERR=1395,IOSTAT=IERR) XSECT FILE 
1 FORMAT {A80) 

IF (XSECT_FILE(1:2) .EQ. ' -1' ) GOTO 1295 
WRITE (6, 1410) XSECT_FILE 
1410 FORMATdx,' Input Proton Cross-Section File = ' / ix A80) 
IFILETYPE=8 

CALL CHECK_FILE (IFILETYPE , XSECT_FILE, lACCEPT) 
IF (lACCEPT.NE.O) GOTO 1395 

ELSEIF ( IPARAM. EQ.l) THEN 
1495 CONTINUE 

CALL RETRY_INPUT{IERR) 
WRITE (6, 1500) 

1500 FORMATC Bendel 1-parameter fit to the cross-section: 

& NOTE: Your fit parameters must specify proton', 

& SEU cross-section (in 10**-12 cm2/bit) vs.', 

& ' proton energy (in MeV) : ' 

& /,' Enter Bendel-l parameter value: ') 

READ { * , * , ERR=14 95 , IOSTAT=IERR) PARAMS ( 1 ) 
IF (PARAMS (1) .LE. -1) GOTO 1295 
WRITE (6, 1510) PARAMS (1) 
1510 FORMATC Bendel-l parameter = ',E13.6) 

ELSEIF ( IPARAM. EQ. 2) THEN 
1595 CONTINUE 

CALL RETRY^INPUT (lERR) 
WRITE (6, 1600) 

1600 FORMATC Bendel 2-parameter fit to the cross - section • ' 

& NOTE: Your fit parameters must specify the proton', 

& SEU cross-section (in 10**-12 cm2/bit) vs.', 

^ ' proton energy (in MeV) : ' 

& / , ' Enter Bendel A & B parameter values • ' ) 

READ(*,*,ERR=1595,IOSTAT=IERR) PARAMS ( 1 ) , PARAMS ( 2 ) 
IF (PARAMS (l).LE.-l. .or. PARAMS (2) . LE . -1 . ) GOTO 1295 
WRITE(6,1610) PARAMS (1) , PARAMS (2) 
1610 FORMATC Bendel parameters A,B = ',2E13.6) 

ELSEIF (IPARAM. EQ. 3. or. IPARAM. LT.O .or. IPARAM. GT. 4) THEN 
1695 CONTINUE 

WRITE (6, 1700) 

1700 FORMATC ILLEGAL CROSS -SECTION SPECIFICATION CODE. ', 

& /,' Please try again.') 



GOTO 12 95 



ELSEIF (IPARAM.EQ.4) THEN 
1795 CONTINUE 

CALL RETRy_INPUT(IERR) 
WRITE{6,1800) 

1800 FORMAT (' Weibull fit to the cross-section: 

& /,' NOTE: Your fit parameters must specify the proton' 

& /,' SEU cross-section (in 10**-12 cm2/bit) vs.', 

& ' proton energy (in MeV) : ') 

WRITE (6, 1810) 

1810 FORMAT (' Enter ONSET parameter (in MeV): ') 

READ ( * , * , ERR= 1795, IOSTAT= I ERR ) PARAMS ( 1 ) 

IF (PARAMS (1) .LE. -1. ) GOTO 1295 
1815 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE (6, 1820) 

1820 FORMAT (' Enter WIDTH parameter (in MeV) : ') 

READ ( * , * , ERR= 1815, IOSTAT= lERR ) PARAMS ( 2 ) 

IF (PARAMS (2) .LE. -1. ) GOTO 1795 
1825 CONTINUE 

CALL RETRY_INPUT(IERR) 

WRITE(6, 1830) 

^ 1830 FORMAT (' Enter POWER parameter (dimensionless exponent): 

y READ(*, *,ERR=1825, IOSTAT=IERR) PARAMS (3) 

^ IF (PARAMS (3) .LE.-l.) GOTO 1815 

D 183 5 CONTINUE 

Q CALL RETRY_INPUT(IERR) 

nj WRITE (6, 1840) 

n 1840 FORMATC Enter cross-section plateau value', 

Ly & ' (in 10**-12 cm2/bit):') 

READ (*, *,ERR= 1835, IOSTAT=IERR) PARAMS (4) 
, IF (PARAMS (4) .LE. -1. ) GOTO 1825 

M WRITE (6, 1850) PARAMS ( 1 ), PARAMS ( 2 ), PARAMS ( 3 ), PARAMS ( 4 ) 

nJ 1850 FORMATC Weibull fit parameters: ', 

U\ ^ /,5x,' ONSET = ',F9.3,' MeV, 

2 ^ //5x,' WIDTH = ',F9.3,' MeV, 

^ ^ //5x,' POWER = ',F9.3,' (dimensionless)', 

^ /,5x,' PLATEAU = ' , F9 . 3 , ' x 10**-12 cm2/bit') 

ENDIF 

1995 CONTINUE 

CALL RETRY_INPUT(IERR) 
WRITE(6,2000) 

2000 FORMATC Finally, specify number of bits per device: ') 
READ(*, *,ERR=1995, IOSTAT=IERR) NBITS 
IF (NBITS. EQ. -1) THEN 

IF (IPARAM.EQ. 1) GOTO 1495 

IF (IPARAM.EQ. 2) GOTO 1595 

IF (IPARAM.EQ. 3) GOTO 1695 

IF (IPARAM.EQ.4) GOTO 1835 
ENDIF 

WRITE (6, 2010) NBITS 
2010 FORMAT (lx,E13. 5, ' bits per device .' ) 



RETURN 
END 





REAL FUNCTI^^ET_TRAPPED_IONS { IZ , EN) 



Returns orbit -averaged flux of trapped ion IZ at energy EN 
--> NOT INCLUDED IN CREME96 



GET__TRAPPED_IONS = 0 . 0 

RETURN 

END 



REAL FUNCTIO] 



TRAPPED PROTONS (EN) 




C 
C 
C 
C 
C 
C 
C 
C 

c 



Returns orbit -averaged trapped proton flux (in protons/m2-s-sr-MeV) 
at energy EN (in MeV) by interpolating value from previously stored 
array. 



Formerly called "TRAPPED_PROTONS" . Renamed by AJT 12-9-97, to 
remove name conflict with new PRB/SAIC routines on trapped protons. 



IMPLICIT NONE 

INTEGER*4 MAXSPEC, ITRPSPEC , I 
REAL* 4 EN, ENTRP, FLUXTRP 
PARAMETER (MAXSPEC=5000 ) 

COMMON/TRPDAT/ITRPSPEC, ENTRP (MAXSPEC) , FLUXTRP (MAXSPEC) 
REAL*4 XI, Y1,X2,Y2,X3, Y3, SLOPE 

GET_TRAPPED_PROTONS=0 . 

IF (EN. LT. ENTRP (1) .or. EN . GT . ENTRP ( ITRPSPEC) ) RETURN 

DO 100 1=2, ITRPSPEC 

IF (EN.LE.ENTRP(I) ) THEN 



IF (FLUXTRP (I) .GT.O. .and. FLUXTRP (I-l) .GT. 0 . ) THEN 
XI =ALOG (ENTRP (I-l) ) 
Y1=AL0G ( FLUXTRP ( I - 1 ) ) 
X2=AL0G(ENTRP(I) ) 
Y2 = ALOG ( FLUXTRP ( I ) ) 
SLOPE= (Y2-Y1) / (X2-X1) 
X3=AL0G(EN) 
Y3=SL0PE* (X3-X1) +Y1 
GET_TRAPPED_PROTONS=EXP {Y3 ) 
GOTO 150 

ELSE 

GET TRAPPED PROTONS =0.0 



ENDIF 



100 
150 



ENDIF 
CONTINUE 
CONTINUE 



RETURN 
END 
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SUBROUTINE UPSET (XM, YM, 2M, FUNNELM, QCR IT, 

NVAL , LVAL , FVAL , UPS ET ) 

Subroutine for evaluating SEUs as a function of critical 
charge. Derived from the UPSET program in the original CREME 
software . 

Inputs: XM,YM,ZM = bit dimensions x,y,z {in microns) 
FUNNELM = funnel length (in microns) 
Qcrit = (critical charge) in picocoulombs 
LVAIi,FVAL = arrays containing integral LET spectrum 

in particles/m2-sr-s 

vs. LET in MeV-cm2/gm 

in NVAL points 
Output: UPSET = SEUs/bit/s 

Modified by AJT 10-24-96: increases density of sampling in 
LET spectrum around values corresponding to peaks in the differential 
pathlength distribution. This removes a previously noted problem 
in the old GET_UPSET routine, in which the SEU rate was not a 
strictly non- increasing function of increasing critical charge. 

Modified by AJT 10-30-96: funnels added. 

Modified by AJT 11-07-96: changed to trapezoidal rule integration, 

as suggested by Ed Petersen. 



BANNER FROM CREME 1981 VERSION: 

THIS PROGRAM COMPUTES THE UPSET RATE DUE TO THE 
DIRECT IONIZATION OF INDIVIDUAL PARTICLES. IT ASSUMES 
THAT FOR EACH BIT THERE EXISTS A SENSITIVE VOLUME. 
IF AN AMOUNT OF ELECTRICAL CHARGE (>QCRIT) IS CREATED 
WITHIN THIS VOLUME BY THE IONIZING PARTICLE, THEN AN 
UPSET WILL OCCUR. THE SENSITIVE VOLUME IS IDEALIZED AS 
A PARALLELEPIPED WITH DIMENSIONS X, Y, AND Z. 

THE OUTPUT IS GIVEN IN UPSETS/ (BIT*SECOND) AND UPSETS/ (BIT*DAY) 

THIS CALCULATION USES THE METHOD DESCRIBED IN "THE VARIABILITY 
OF SINGLE EVENT UPSET RATES IN THE NATURAL ENVIRONMENT, " 
JAMES H. ADAMS, JR., IEEE TRANS. ON NUCL. SCI., NS-30, 4475- 
4480, DEC, 1983. 

IT IS OPERATIONALLY EQUIVALENT TO ROCKWELL'S CRIER PROGRAM - 
(PICKEL AND BLANDFORD, IEEE TRANS. ON NUCL. SCI. NS-26, DEC. 
1979, PP. 4735-4739) WHEN USED WITH HEINRICH'S LET SPECTRUM 
(W. HEINRICH, RADIATION EFFECTS, VOL. 34, PP. 143-8, 1977). 

THIS PROGRAM CALLS A SUBPROGRAM, DIFPLD, THAT RETURNS 

THE DIFFERENTAL PATHLENGTH DISTRIBUTION IN THE SENSTIVE VOLUME 



IMPLICIT NONE 

INTEGER*4 NBINS , NVAL, I , K, N 

REAL* 4 XM, YM, ZM, FUNNELM, QCRIT, LVAL, FVAL, UPSET 

REAL*4 L, FLUX, X, Y, Z,DSI, AREA, PMAX, ENERGY, LMIN, SUM, Q 

REAL* 4 D, DIFPLD 

REAL* 4 FUNNEL 

REAL*4 INTGRNDO, INTGRND 

PARAMETER (NBINS=5000} 



DIMENSION 



NS) ,FLUX(NBINS) 



C 

c 
c 




c 
c 
c 



c 
c 
c 

c 
c 
c 
c 

c 
c 
c 
c 



DIMENSION LVAL ( 1 ) , FVAL ( 1 ) 
DATA DSI/2.321/ 
REAL*4 LUSE,FUSE 

DIMENSION LUSE(NBINS) ,FUSE(NBINS) 
INTEGER*4 M,IENTER 

Load the inputs 

IF (lENTER.EQ. 0) THEN 

IENTER=1 

WRITE{6, 9999) 

FORMATdX,' GET_UPSET revision 11/08/96 active: ') 
ENDIF 

UPSET=0.0 

CALL TEMP_STORAGE (NBINS , NVAL, LVAL, FVAL, N, L, FLUX) 



RPP Dimensions : 

X^XM 
Y=YM 
2=ZM 

FUNNEL= FUNNELM 

CONVERT FROM MICROMETERS TO CENTIMETERS. 
X=X*.0001 

Y=y*.oooi 

Z=Z*.0001 

FUNNEL= FUNNEL* 0 . 0001 

COMPUTE THE SURFACE AREA OF THE SENSITIVE VOLUME. 
AREA= (2 . *X*Y+2 . *X*Z+2 . *Y*Z) 

CONVERT FROM SQUARE CENTIMETERS TO SQUARE METERS. 
AREA=AREA* .0001 

CONVERT THE DIMENSIONS OF THE SENSITIVE VOLUME TO G/CM**2. 

X=X*DSI 
Y=Y*DSI 
Z=Z*DSI 

FUNNEL=FUNNEL*DSI 

COMPUTE THE MAJOR DIAMETER OF THE SENSITIVE VOLUME. 
PMAX=SQRT (X*X+Y*Y+Z*Z) 

COMPUTE THE ENERGY (IN MEV) REQUIRED TO PRODUCE QCRIT(IN PC) 
HOLE -ELECTRON PAIRS IN SILICON. 

ENERGY=22 . 5*QCRIT 

COMPUTE THE MINIMUM LET THAT CAN PRODUCE AN UPSET. 
Funnel added to this equation 10/30/96 AJT 



LMIN=ENERGY/10K 

LMIN=ENERGy/ (PMAX+FUNNEL) 



Modification AJT 10/24/96: expand sampling aroimd discontinuities 
in the pathlength density distribution 

CALL EXPAND_SAMPLING (NBINS , N, L, FLUX, LMIN, ENERGY, PMAX, X, Y, Z, 

M,LUSE,FUSE) 



Now use expanded sampling in numerical integration: 

INTEGRATE FROM LMIN TO THE LARGEST LET IN THE SPECTRUM. 

SUM=0.0 
Q=LMIN 

Note: to uses the trapezoidal rule in the numerical integration, 
we need to evaluate the integrand (DIFPLD*FLUX/L**2) on a grid 
which includes the endpoints of the integration. The lower endpoint 
is at LMIN, which corresponds to PMAX, the longest possible path 
through the RPP. However, DIFPLD=0 at PMAX. Thus, the integrand 
also vanishes at LMIN. 

INTGRNDO=0.0 

DO 10 1=1, M 

IF (LUSE(I) .LT.LMIN) GO TO 10 

Terminate numerical integration when integral flux falls to zero. 
IF (FUSE(I) .LE.0.0) GOTO 11 

COMPUTE THE PATHLENGTH CORRESPONDING TO L(I) . 

Funnel added to this equation 10/30/96 AJT 

D=ENERGY/LUSE(I) 

D= (ENERGY/LUSEd) -FUNNEL) 

IF (D.LT.0.0) D=0.0 



CARRY OUT THE INTEGRAL. 

Modified to use trapezoidal rule 11/7/96: 

SUM=SUM+ (LUSE (I) -Q) *DIFPLD (D,X, Y, Z) *FUSE (I) / (LUSE (I) **2) 

INTGRND=DIFPLD(D,X, Y, Z) *FUSE(I) / (LUSE (I) **2) 
SUM=SUM+0. 5* (LUSE (I) -Q) * (INTGRND+INTGRNDO) 
INTGRND 0 = INTGRND 

Q=LUSE{I) 

CONTINUE 

CONTINUE 

COMPUTE THE ERROR RATE. 



CONTINUE 



UPSET=ENERGY 



*3 .1416*SUM 




RETURN 
END 



SUBROUTINE TEMP_STORAGE (NBINS , NVAL, LVAL, FVAL, N, L, FLUX) 

IMPLICIT NONE 

INTEGER*4 NBINS , NVAL, N, K 

REAL*4 LVAL,FVAL,L,FLUX 

DIMENSION LVAL(l) ,FVAL{1) ,L(1) ,FLUX(1) 

: Copy Integral LET spectrum: 

DO 5 K=1,NVAL 

L(K) =:LVAL{K) 
FLUX(K) =FVAL{K) 

5 CONTINUE 
N=NVAL 

IF (N.GT. NBINS) THEN 

WRITE (6, 9999) N, NBINS 
9999 FORMATC® 10002 ABNORMAL TERMINATION: 

& /,lx,' LET spec array out of bounds in GET_UPSET: ' 

& /, Ix, ' N = ' , 18, ' NBINS = ',18, 

& /,lx,' STOP.') 

STOP 

ENDIF 

RETURN 

END 



SUBROUTINE EXPAND_SAMPLING (NBINS , N, L, FLUX, 
& LMIN, ENERGY, PMAX,X,Y, Z, 

& M,LUSE,FUSE) 

IMPLICIT NONE 

INTEGER* 4 NBINS , N, M, TBINS 

REAL*4 L,FLUX,LMIN, ENERGY, PMAX,X,Y,Z,LUSE, FUSE 
DIMENSION L(l) ,FLUX(1) ,LUSE(1) ,FUSE(1) 
PARAMETER (TBINS=5000) 
REAL* 4 LTEMP,FTEMP 

DIMENSION LTEMP (TBINS) , FTEMP (TBINS ) 
INTEGER*4 I,K 

REAL* 4 S , STEMP , SDUM , XVAL , YVAL 
REAL*4 SCALE, SMALLEST, SAMPLE_S I ZE 
DATA SCALE/0.01/ 
REAL*4 DSI 
DATA DSl/2.321/ 

For idiot checks: 

REAL*4 DUM,DIFPLD,STEMPDUM 

INTEGER* 4 INDX 
DIMENSION INDX (TBINS) 




C NOTE: X,Y,^Ksumed here to be in g/cm2!! 

C 

C Store relevant portion of input LET spectrum- 

M=0 

DO 4 1=1, N 

IF (Ld) .LT.LMIN) GO TO 4 
IF (FLUX(I) .LE.0.0) GOTO 6 
M=M+1 

LTEMP (M)=L(I) 

FTEMP (M)=FLUX(I) 
4 CONTINUE 
6 CONTINUE 

C Now we wish to do additional samplings around the peaks 

C in the pathlength distribution. 

C Specifically, the additional sampling is done on a scale 

C equal to 1% of the smallest dimension, but no larger than 0.01 

C microns. The sampling is done at 100 points ranging from 

C x-10*scale to x+90*scale. 

PMAX=SQRT (X*X+Y*Y+Z*2) 
SMALLEST=MIN (X, Y, Z) /O . OOOl/DSI 
SAMPLE_S I ZE=SCALE* SMALLEST 

IF (SAMPLE_SIZE.GT. 0.01) SAMPLE_SIZE=0 . 01 

DO 50 K=l,3 

IF (K.EQ.l) S=X 
IF {K.EQ.2) S=Y 
IF {K.EQ.3) S=Z 
C Suppress redundant samplings: 

IF (K.EQ.2 .and. (ABS (X- Y) . LE . 0 . 0001*X) ) GOTO 50 
IF {K.EQ.3 .and. 

& (ABS(X-2) .LE.0.0001*X .or. ABS (Y- Z) . LE . 0 . 0001*Y) ) GOTO 50 

DO 45 I=-ll,89 

S TEMP= S + FLOAT { I ) * S AMPLE_S I2E*0.0001*DSI 

IF (STEMP.LE.O. .or. STEMP . GT . PMAX) GOTO 45 
C 

C Idiot checks again: 

C DUM=DIFPLD (STEMP, X, Y, Z) 

C SDUM=S/DSI/0.0001 

C STEMPDUM=STEMP/DSI/0.0001 

C TYPE*,' S,I,STEMP(mics) ,DPLD: ' , SDUM, I , STEMPDUM, DUM 

IF (M.LT. THINS -1) THEN 
M=M+1 

LTEMP (M) =ENERGY/STEMP 
XVAL=LTEMP (M) 

CALL INTERPOLATE_INTLET (XVAL , N, L , FLUX , YVAL) 
FTEMP (M)=YVAL 
ENDIF 

45 CONTINUE 
50 CONTINUE 



C 
C 
C 
C 



We now have the appropriate array of LET and FLUX values 
For the numerical integration, these must be ordered. 
Use the INDEXX routine from Numerical Recipes: 



CALL INDEXX (M, THINS , LTEMP , INDX) 




UPSET=ENERGY^1?EA*3 . 1416*SUM 



RETURN 
END 



C 

SUBROUTINE TEMP_STORAGE (NBINS , NVAL, LVAL, FVAL, N, L, FLUX) 

IMPLICIT NONE 

INTEGER* 4 NBINS , NVAL, N, K 

REAL*4 LVAL, FVAL, L, FLUX 

DIMENSION LVALd) ,FVAL(1) ,'L(1) ,FLUX{1) 

C Copy Integral LET spectrum: 

DO 5 K=1,NVAL 

L(K)=LVAL(K) 
FLUX(K)=FVAL(K) 

5 CONTINUE 
N=NVAL 

IF (N.GT. NBINS) THEN 
^ WRITE (6, 9999) N, NBINS 

^ 9999 FORMATC® 10002 ABNORMAL TERMINATION: ', 

^ & /,lx,' LET spec array out of bounds in GET_UPSET: ' 

y & /, Ix, ' N = ' , 18, ' NBINS = ',18, 

y & /,lx,' STOP.') 

lU STOP 

U ENDIF 

yj RETURN 

H END 

^ C 

ru 

y SUBROUTINE EXPAND_SAMPLING (NBINS , N, L, FLUX , 

U & LMIN, ENERGY, PMAX,X,Y,Z, 

yp & M,LUSE,FUSE) 

" IMPLICIT NONE 

INTEGER*4 NBINS , N, M, TBINS 

REAL* 4 L , FLUX , LMIN , ENERGY , PMAX , X , Y , Z , LUSE , FUSE 
DIMENSION L(l) ,FLUX(1) ,LUSE(1) ,FUSE(1) 
PARAMETER (TBINS=5000) 
REAL*4 LTEMP,FTEMP 

DIMENSION LTEMP (TBINS) , FTEMP (TBINS ) 
INTEGER* 4 I,K 

REAL* 4 S,STEMP,SDUM,XVAL,YVAL 
REAL*4 SCALE, SMALLEST, SAMPLE_S I ZE 
DATA SCALE/0.01/ 
REAL* 4 DSI 
DATA DSl/2.321/ 

C For idiot checks : 

C REAL*4 DUM,DIFPLD,STEMPDUM 

INTEGER*4 INDX 
DIMENSION INDX (TBINS) 



C 



C NOTE: X,y,Z^Kumed here to be in g/cm2!!! 

C . 

C Store relevant portion of input LET spectrum: 

M=0 

DO 4 1=1, N 

IF (L(I) .LT.LMIN) GO TO 4 
IF (FLUX(I) .LE.0.0) GOTO 6 
M=M+1 

LTEMP(M) =L(I) 

FTEMP{M)=FLUX(I) 
4 CONTINUE 
6 CONTINUE 




C Now we wish to do additional samplings around the peaks 

C in the pathlength distribution. 

C Specifically, the additional sampling is done on a scale 

C equal to 1% of the smallest dimension, but no larger than 0.01 

C microns. The sampling is done at 100 points ranging from 

C x-10*scale to x+90*scale. 



PMAX=SQRT (X*X+y*Y+Z*Z) 
SMALLEST=MIN (X, Y, Z) /O . OOOl/DSI 
SAMPLE_SIZE=SCALE*SMALLEST 

IF (SAMPLE_SIZE.GT.0.01) SAMPLE_SIZE=0 . 01 

DO 50 K=l,3 

IF (K.EQ.l) S=X 
IF (K.EQ.2) S=Y 
IF {K.EQ.3) S=Z 
Suppress redundant samplings: 

IF (K.EQ.2 .and. (ABS (X-Y) . LE . 0 . 0001*X) ) GOTO 50 
IF (K.EQ.3 .and. 

(ABS{X-Z) .LE.0.0001*X .or. ABS (Y-Z) . LE . 0 . 0001*Y) ) GOTO 50 
DO 45 I=-ll, 89 

S TEMP = S + FLOAT { I ) * S AMPLE_S IZE*0.0001*DSI 
y IF (STEMP.LE. 0 . .or. STEMP . GT . PMAX) GOTO 45 

iQ C Idiot checks again: 

Q C DUM=DIFPLD (STEMP, X,Y, Z) 

" C SDUM=S/DSI/0. 0001 

C STEMPDUM=STEMP/DSI/0 .0001 

C TYPE S, I,STEMP(mics) ,DPLD: ' , SDUM, I , STEMPDUM, DUM 
C . 

IF (M.LT.TBINS-1) THEN 
M=M+1 

LTEMP (M) =ENERGY/STEMP 
XVAL=LTEMP(M) 

CALL INTERPOLATE_INTLET (XVAL, N, L, FLUX, YVAL) 
FTEMP (M) =YVAL 
ENDIF 

45 CONTINUE 
50 CONTINUE 



We now have the appropriate array of LET and FLUX values. 
For the numerical integration, these must be ordered. 
Use the INDEXX routine from Numerical Recipes: 



CALL INDEXX (M, TB INS , LTEMP , INDX) 



Now store th^Walues according to increasing 
DO 55 1=1, M 

IF (I.LE.NBINS.AND.I.LE.TBINS 

.AND.INDXd) .LE.TBINS) THEN 
LUSE ( I ) =LTEMP ( INDX ( I ) ) 
FUSE (I) =FTEMP{INDX(I) ) 

ELSE 

WRITE (6, 9999) M, NBINS , TBINS , I , INDX { I ) 
FORMAT ( ' FATAL ERROR IN GET_UPSET : ' , 
M,NBINS,TBINS: ',316, 
/, ' I,INDX(I) : ' ,216) 

ENDIF 
CONTINUE 
RETURN 
END 



SUBROUTINE INTERPOLATE_INTLET (X, N, L, FLUX, Y) 

Does a linear interpolation on a log-log plot of the 
integral flux vs . LET curve . 



IMPLICIT NONE 

INTEGER* 4 N 

REAL*4 X,Y,L,FLUX 

DIMENSION L(1),FLUX(1) 

REAL*8 XI, X2,X3,Y1,Y2,Y3, SLOPE 

INTEGER* 4 I 

IF (X.LE.Ld) ) THEN 

Y=FLUX{1) 
ELSEIF (X.GT.L(N)) THEN 

Assume integral flux vanishes above the highest L value. 

Y=0,0 

ELSE 

DO 100 1=1, N-1 

IF (X.LE.L(I+1) ) THEN 

IF (FLUX(I) .GT.O. .and. FLUX (I+l) .GT . 0 . ) THEN 
X1=AL0G(L(I) ) 
Y1=AL0G(FLUX{I) ) 
X2=AL0G(L(I + 1) ) 
Y2=AL0G{ FLUX (I+l) ) 
SLOPE= (Y2-Y1) / {X2-X1) 
X3=AL0G(X) 
Y3=SL0PE* (X3-X1) +Y1 
Y=EXP(Y3) 
GOTO 150 

ELSE 

Y=0. 0 
ENDIF 
ENDIF 
CONTINUE 
CONTINUE 
ENDIF 
RETURN 
END 



LOGICAL FUNCTTON INIGRID 
C 
C 

C This version uses the Epoch 1980.0 vertical cutoff grid of 

C Shea and Smart . 

C 

IMPLICIT NONE 



INTEGER I, J 

REAL CUTOFF (33, 72) ,CN,CS 



C0MM0N/CUT0FF8 0 /CUTOFF, CN, CS 

C 

C This common block contains the table of world wide vertical 

C geomagnetic cutoffs at 20 km altitude, tabulated every 5 degrees 

C in latitude (to +/- 80 degrees) and 5 degrees in longitude. It 

C was given to JHA by private communication from D.F. Smart on 11/27/89. 

C This calculation is for Epoch 1980.0, ie, the cutoff calculation used 

C the 10th degree IGRF model (1980), as discussed in Shea & Smart, Proc . 

C 18th ICRC, V. 3, p. 415 (1983) . 



DATA (CUTOFFd, J) , J=l, 72) / 





# 


0.34, 


0. 31, 


0.29, 


0.26, 


0 


.23, 


0 


21, 


0 


.18, 


0 


.16, 


0 


.14, 




# 


0.12, 


0. 10, 


0.09, 


0 . 07 , 


0 


.05, 


0 


04, 


0 


.02, 


0 


.01, 


0 


.01, 




# 


0. 00, 


0.00, 


0.00, 


0.00, 


0 


.00, 


0 


00, 


0 


. 00, 


0 


. 00, 


0 


.00, 


r: 


# 


0.00, 


0. 00, 


0.00, 


0.00, 


0 


. 00, 


0 


00, 


0 


. 00, 


0 


.01, 


0 


.01, 


y 


# 


0. 02, 


0. 04, 


0.05, 


0.07, 


0 


.09, 


0 


10, 


0 


.12, 


0 


.15, 


0 


.17, 


y 


# 


0.20, 


0.23, 


0.25, 


0.28, 


0 


.32, 


0 


35, 


0 


.39, 


0 


.41, 


0 


.43, 




# 


0.45, 


0.47, 


0.50, 


0.52, 


0 


.53, 


0 


53, 


0 


.54, 


0 


.54, 


0 


.53, 


Q ' 


# 


0.53, 


0. 52, 


0.51, 


0.50, 


0 


.46, 


0 


43, 


0 


.39, 


0 


.37, 


0 


.36/ 






DATA (CUT0FF(2, J) , J=l,72)/ 
























# 


0. 59, 


0.51, 


0.45, 


0.42, 


0 


.37, 


0, 


34, 


0 


.28, 


0 


.25, 


0 


.21, 




# 


0.18, 


0. 15, 


0.12, 


0. 10, 


0 


.08, 


0, 


06, 


0 


.04, 


0 


. 02, 


0 


.00, 




# 


0.00, 


0. 00, 


0. 00, 


0.00, 


0 


.00, 


0. 


00, 


0 


.00, 


0 


.00, 


0 


. 00, 




# 


0.00, 


0. 00, 


0.00, 


0.00, 


0 


. 00, 


0. 


00, 


0 


.00, 


0 


.00, 


0 


.02, 




# 


0. 04, 


0.07, 


0.09, 


0.11, 


0 


.15, 


0. 


18, 


0 


.22, 


0 


24, 


0 


.30, 




# 


0,34, 


0.42, 


0.48, 


0. 53, 


0 


.60, 


0. 


65, 


0 


70, 


0 


75, 


0 


.83, 




# 


0.87, 


0. 91, 


0. 90, 


1. 01, 


1 


00, 


1. 


07, 


1 


04, 


1 


03, 


1 


.03, 




# 


0.98, 


0. 93, 


0.93, 


0.86, 


0 


82, 


0. 


79, 


0 


72, 


0 


66, 


0 


.60/ 






DATA (CUT0FF(3, J) , J=l, 72) / 
























# 


0.84, 


0.79, 


0. 73, 


0.66, 


0 


58, 


0. 


50, 


0 


46, 


0 


39, 


0 


.36, 




# 


0.30, 


0.24, 


0.21, 


0.16, 


0 


13, 


0. 


10, 


0 


08, 


0 


05, 


0 


.03, 




# 


0.00, 


0. 00, 


0.00, 


0.00, 


0 


00, 


0. 


00, 


0 


00, 


0 


00, 


0 


.00, 




# 


0.00, 


0.00, 


0.00, 


0.00, 


0 


00, 


0. 


00, 


0 


02, 


0 


05, 


0 


.08, 




# 


0.10, 


0.14, 


0.18, 


0.22, 


0 


27, 


0. 


30, 


0 


40, 


0 


47, 


0 


.53, 




# 


0.60, 


0.72, 


0.80, 


0. 90, 


1 


06, 


1. 


11, 


1 


20, 


1. 


30, 


1 


.43, 




# 


1.51, 


1.61, 


1.64, 


1.67, 


1 


72, 


1. 


74, 


1 


75, 


1, 


70, 


1 


.65, 






1.59, 


1.52, 


1.42, 


1.33, 


1 


27, 


1 . 


22, 


1 


11, 


1 . 


04, 


0 


.95/ 






DATA (CUT0FF(4, J) , J=l,72) / 
























# 


1.29, 


1.15, 


1.03, 


0. 96, 


0 


85, 


0. 


76, 


0. 


72, 


0. 


60, 


0 


.57, 




# 


0.48, 


0.41, 


0.35, 


0.29, 


0. 


25, 


0. 


19, 


0. 


14, 


0. 


13, 


0 


.09, 




# 


0.06, 


0.04, 


0.02, 


0.00, 


0. 


00, 


0. 


00, 


0. 


00, 


0. 


00, 


0 


.00, 




# 


0.00, 


0.00, 


0.02, 


0.03, 


0. 


05, 


0. 


08, 


0. 


10, 


0. 


14, 


0 


.18, 




# 


0 .22, 


0.27, 


0.35, 


0.42, 


0. 


49, 


0. 


61, 


0. 


69, 


0. 


80, 


0 


94, 




# 


1.05, 


1.21, 


1.34, 


1.55, 


1. 


65, 


1. 


86, 


1. 


96, 


2 . 


14, 


2 


32, 




# 


2 .46, 


2. S3, 


2.67, 


2.72, 


2 . 


70, 


2 . 


71, 


2 . 


63, 


2. 


56, 


2 


51, 




# 


2 .40, 


2.27, 


2.20, 


2. 02, 


1 . 


87, 


1 . 


70, 


1 . 


61, 


1. 


45, 


1 


35/ 






DATA (CUTOFF (5 


,J),J=1,72)/ 
























# 


1.69, 


1.53, 


1.45, 


1.29, 


1. 


15, 


1 . 


11, 


1. 


03, 


0. 


94, 


0 


83, 




# 


0 .76, 


0.65, 


0. 59, 


0.49, 


0. 


42, 


0. 


36, 


0. 


30, 


0. 


25, 


0 


20, 



# 


0 


.15, 


0 




0 


.11, 


0 


.09. 


# 


0 


. 08, 


0 


.09, 


0 


.12, 


0 


.14. 


# 


0 


.51, 


0 


.58, 


0 


.68, 


0 


.76, 


# 


1 


.77, 


1 


.93, 


2 


.10. 


2 


.27, 


# 


3 


.75, 


3 


.79, 


3 


.91. 


4 


.01, 


# 


3 


.39, 


3 


.21, 


2 


.98, 


2 


.72, 




DATA (CUTOFF {6 


.J) 


, J=l,72)/ 


# 


2 


.17, 


1. 


.97, 


1 


.86, 


1 . 


.72, 


# 


1, 


.14, 


1. 


00, 


0 


.92. 


0, 


.82, 




0. 


.35, 


0. 


31, 


0 


.27, 


0. 


24, 


# 


0. 


25, 


0. 


28, 


0, 


.32, 


0. 


38, 


# 


0. 


95, 


1. 


07, 


1. 


.22, 


1 . 


36, 


# 


2. 


64, 


2. 


80,- 


3 . 


.03, 


3 . 


35, 


# 


4 . 


90, 


5. 


07, 


5. 


10, 


5 . 


18, 


# 


4 . 


25, 


3. 


98, 


3 . 


70, 


3 . 


48, 



DATA (CUTOFF(7, J) , J=l,72) / 



# 


2 


.76, 


2.55, 


2 


.38, 


2 .27, 


# 


1 


.64, 


1.52, 


1 


.42, 


1.30, 




0 


.71, 


0.67, 


0 


.58, 


0.56, 




0 


.60, 


0.66, 


0 


.71, 


0.81, 


# 


1 


.65, 


1.83, 


2 


.03, 


2.24, 


# 


. 3 


.79, 


4.05, 


4 


.20, 


4.58, 


# 


7 


.05, 


7.36, 


7 


.42, 


7.41, 


# 


5 


.47, 


5.01, 


4 


.60, 


4.27, 




DATA (CUTOFF (8, J) 


, J-1,72)/ 


# 


3 


.33, 


3.22, 


3 


.01, 


2.88, 


# 


2 


.38, 


2.29, 


2 


.10, 


2.00, 


# 


1, 


.28, 


1.18, 


1 


.14, 


1.12, 


# 


1, 


.22, 


1.33, 


1 


.36, 


1.47, 


# 


2 . 


.69, 


2.96, 


3, 


.15, 


3.30, 


# 


4 . 




5.29, 


5. 


.61, 


6. 01, 


# 


8. 


,89, 


8.97, 


8, 


.77, 


8. 52, 


# 


6. 


80, 


6.43, 


5. 


.89, 


5.34, 




DATA (CUT0FF(9, J) , J=l, 72) / 




4 , 


03, 


3.85, 


3. 


72, 


3.62, 


# 


3 . 


26, 


3.18, 


3. 


00, 


2.89, 


# 


2 . 


21, 


2 .06, 


2. 


02, 


2.04, 


# 


2. 


22, 


2.31, 


2 . 


43, 


2.53, 


# 


4 . 


15, 


4 .48, 


4 . 


76, 


4.84, 


# 


6. 


76, 


7.27, 


7. 


91, 


8.18, 


# 


10. 


08, 


9.98, 


9. 


81, 


9.63, 


# 


7. 


35, 


6.82, 


6. 


68, 


6.18, 



DATA (CUTOFFdO, J) , J=l, 72)/ 



# 


5 


.05, 


4.79, 


4 


.65, 


4 


.49, 


# 


4 


.38, 


4 .34, 


4, 


.26, 


4 


.12, 


# 


3, 


.47, 


3 140, 


3, 


.40, 


3 


.41, 


# 


3 , 


.55, 


3.69, 


3 . 


.89, 


4, 


.10, 


# 


5. 


.65, 


5.95, 


6. 


.25, 


6, 


.62, 


# 


8. 


.73, 


8 .41, 


9, 


,00, 


9. 


.62, 


# 


11 . 


09, 


10.95, 


10. 


75, 


10. 


55, 


# 


8. 


,50, 


7.99, 


7. 


47, 


6. 


88, 




DATA (CUTOFF (11, J) 


, J= 


1,72)/ 


# 


6 . 


11, 


5.99, 


5. 


86, 


5. 


84, 




5. 


80, 


5.74, 


5. 


72, 


5. 


58, 


# 


5. 


19, 


5.14, 


5. 


18, 


5. 


14, 


# 


5 . 


38, 


5.45, 


5. 


60, 


5. 


84, 


# 


7 . 


98, 


8.58, 


9. 


05, 


9. 


45, 


# 


10. 


75, 


11.25, 


11. 


69, 


11. 


79, 


# 


11. 


78, 


11.67, 


11. 


53, 


11. 


34, 


# 


9. 


57, 


9.15, 


8. 


65, 


8. 


15, 



0.08, 


0.07, 


0.06, 


0.06, 


0.07, 


0.16, 


0.22, 


0.26, 


0.32, 


0.39, 


0.93, 


1.07, 


1 .20, 


1.38, 


1.54, 


2 . 64 , 


2.76, 


^ . 7 o , 




3.49, 


3.94, 


3 . 94, 


3 .82, 


3.71, 


3.57, 


2.52, 


2 . 35, 


2 .14, 


2.01, 


1.78/ 


1.66, 


1.56, 


1.45, 


1.30, 


1.20, 


0.73, 


0.65, 


0.56, 


0.47, 


0.41, 


0.22, 


0.21, 


0 .21, 


0.21, 


0.24, 


0.43, 


0.51, 


0 . 59, 


0.67, 


0.80, 


1.58, 


1. 76, 


1 . 94, 


2.18, 


2.33, 


3.80, 


^ * yj ^ f 


4 0 Q 




4 . 75, 


5.17, 


5.00, 


4 . 90, 


4 .74, 


4 . 54, 


3 .21, 


2. 98, 


2 . 77, 


2 .51, 


2.32/ 


2 .09, 


2 . 02, 


1. 97, 


1.85, 


1.73, 


1.19, 


1. 05, 


0.94, 


0.86, 


0.78, 


0.53, 


0.53, 


0.53, 


0.51, 


0.56, 


0.89, 


1.01, 


1.15, 


1.27, 


1.42, 


2.51, 


2 .70, 


2 .94, 


3.15, 


3.40, 


4.85, 








0.62, 


7.32, 


7.10, 


e .71, 


6.37, 


5.95, 


4.00, 


3 .62, 


3 .42, 


3.14, 


2.87/ 


2 .80, 


2 .67, 


2 . 53, 


2.50, 


2.47, 


1.82, 


1.69, 


1.54, 


1.47, 


1.35, 


1.08, 


1.08, 


1.10, 


1.13, 


1.16, 


1.67, 


1.79, 


2 .01, 


2.17, 


2.43, 


3 .70, 


4.08, 


4 .28, 


4.42, 


4.63, 


6.63, 


7 41 


7 ft 7 

/.Off 


O . XD , 


o . b 3 , 


8.31, 


8.01, 




7.58, 


7.16, 


4 .85, 


4.43, 


4.15, 


3 .82, 


3.52/ 


3.49, 


3.41, 


3 ,38, 


3.33, 


3.33, 


2.77, 


2.69, 


2.58, 


2.35, 


2.25, 


2.05, 


2.05, 


2 . 04, 


2.01, 


2.14, 


2.86, 


2 . 96, 


3.29, 


3.48, 


3.74, 


5.05, 


5.30, 


5.60, 


5.96, 


6.31, 


8 . 55 , 


:? . J. X , 


Q 71 


in n c 


10.14, 


9.39, 


9.13, 


8.80, 


8.32, 


7.88, 


5.94, 


5.48, 


5 . 00, 


4.60, 


4.34/ 


4 .42, 


4.39, 


4.37, 


4.33, 


4.39, 


4.12, 


3.99, 


3 .85, 


3.68, 


3.52, 


3.35, 


3.35, 


3.34, 


3.37, 


3.45, 


4.35, 


4.51, 


4 . 90, 


5.18, 


5.38, 


7.01, 


7.47, 


8 .01, 


8.51, 


8.84, 



10.73, 10.95, 11.05, 11.10, 11.12, 
10.29, 10.01, 9.73, 9.39, 9.00, 
6.52, 6.12, 5.95, 5.66, 5.32/ 



5 


.85, 


5 


.83, 


5 


.84, 


5 


.82, 


5 


.91, 


5 


.51, 


5, 


.45, 


5 


.40, 


5 


.27, 


5, 


.23, 


5 


.13, 


5. 


.06, 


5 


.09, 


5 


.21, 


5, 


.22, 


6 


.02, 


6. 


.32, 


6 


.60, 


6, 


.91, 


7. 


.46, 


9 


.84, 


9. 


.25, 


9 


.40, 


9, 


.59, 


10. 


.12, 


.1 


.86, 


11. 


.91, 


11 


.92, 


11. 


■91, 


11. 


,87, 


.1 


.12, 


10. 


85, 


10 


. 56, 


10. 


.29, 


9. 


95, 


7 


.62, 


7. 


14, 


6 


.88, 


6 . 


74, 


6, 


33/ 



t • 

DATA (CUT0FF(T2, J) , J=l, 72) / 





# 


7 


.28, 


7 


.32, 


7 


.35, 


7 


.29, 


7 


.45, 


7 


.52, 


7 


.63, 


7 


.73, 


7 


.82, 




# 


7 


.93, 


8 


.02, 


8 


.03, 


8 


.02, 


8 


.02, 


7 


.88, 


7 


.71, 


7 


.53, 


7 


.37, 




# 


7 


.28, 


7 


.29, 


7 


.30, 


7 


.26, 


7 


.35, 


7 


.35, 


7 


.42, 


7 


.44, 


7 


.55, 




# 


7 


.64, 


7 


.82, 


8 


.06, 


8 


.36, 


8 


.75, 


9 


.24, 


9 


.49, 


9 


.96, 


10 


.40, 




# 


10 


.19, 


10 


.44, 


10 


.76, 


11 


.24, 


11 


.61, 


11 


.82, 


11 


.98, 


12 


.26, 


12 


.48, 




# 


12 


.56, 


12 


.62, 


12 , 


.65, 


12 


.67, 


12 


.68, 


12 


.66, 


12 


.63, 


12 


.57, 


12 


.49, 




# 


12 


.38, 


12 


.25, 


12 , 


.10, 


11 


.94, 


11 


.76, 


11 


.59, 


11 


.40, 


11 


.13, 


10 


.84, 




# 


10 


.52, 


10 


.21, 


9. 


.79, 


9 


.35, 


8 


.95, 


8 


.50, 


8 


.04, 


7 


.78, 


7 


.51/ 






DATA (CUTOFF (13, J) 


' , J= 


1,72)/ 
























# 


8 


.87, 


8 


.81, 


8. 


.79, 


8 


.89, 


8 


.99, 


9 


.05, 


9 


.26, 


9 


.42, 


9 


.60, 




# 


9 


.74, 


9 


.92, 


10. 


,02, 


10 


.24, 


10 


.42, 


10 


.26, 


10 


.45, 


10 


.52, 


10 


.53, 




# 


10 


.55, 


10 


.58, 


10. 


64, 


10 


.69, 


10 


.73, 


10 


.69, 


10 


.75, 


10 


.56, 


10 


.63, 




# 


10 


.66, 


10 


.38, 


10, 


49, 


10 


.62, 


10; 


.90, 


11 


.30, 


11 


.87, 


12 


.27, 


12, 


.56, 




# 


12 


.72, 


12 , 


.86, 


13. 


02, 


13 


.15, 


13, 


.23, 


13 


.31, 


13 


.36, 


13 


.40, 


13, 


.41, 




# 


13 


.42, 


13, 


.41, 


13. 


38, 


13 


.35, 


13, 


.30, 


13, 


.25, 


13 , 


.17, 


13 


.08, 


12 , 


.98, 




# 


12, 


.85, 


12 , 


.71, 


12. 


57, 


12, 


.42, 


12, 


.28, 


12, 


.14, 


11, 


.99, 


11 


.85, 


11. 


,69, 




# 


11, 


.47, 


11, 


.28, 


10. 


84, 


10, 


.49, 


10. 


.14, 


9. 


.75, 


9, 


.47, 


9, 


.19, 


9. 


,05/ 






DATA (CUTOFF (14, J) 


, J= 


1,72)/ 






















# 


10. 


.45, 


10. 


.49, 


10. 


61, 


10, 


.63, 


10. 


.75, 


10. 


.92, 


11. 


.08, 


11. 


.32, 


11. 


57, 






11. 


.75, 


11. 


,92, 


12. 


13, 


12 . 


.32, 


12. 


,48, 


12 . 


.70, 


12 . 


,80, 


12 . 


.91, 


12 . 


99, 




# 


13 . 


,06, 


13 . 


.14, 


13. 


20, 


13 . 


.24, 


13. 


,23, 


13. 


.20, 


13 . 


17, 


13 . 


13, 


13 . 


13, 




# 


13 . 


18, 


13, 


25, 


13. 


32, 


13. 


.39, 


13. 


48, 


13. 


,58, 


13 . 


,69, 


13 . 


,81, 


13. 


93, 




# 


14. 


01, 


14 . 


09, 


14 . 


14, 


14 . 


.17, 


14 . 


17, 


14 . 


17, 


14 , 


15, 


14 . 


12, 


14 . 


08, 




# 


14 . 


03, 


13 . 


98, 


13. 


91, 


13. 


,84, 


13. 


76, 


13. 


67, 


13 . 


57, 


13 . 


46, 


13 . 


33, 






13 . 


19, 


13 , 


04, 


12 . 


90, 


12 . 


77, 


12 . 


65, 


12, 


56, 


12 . 


47, 


12 . 


38, 


12 . 


28, 




# 


12. 


15, 


11 . 


98, 


11. 


78, 


11. 


53, 


11. 


32, 


11. 


08, 


10. 


79, 


10 . 


62, 


10. 


50/ 






DATA (CUTOFF (15, J) 


, J=: 


1,72)/ 
























# 


11. 


86, 


11. 


92, 


12 . 


01, 


12 . 


11, 


12 . 


23, 


12. 


39, 


12 . 


57, 


12. 


77, 


12 . 


99, 




# 


13 . 


23, 


13 . 


46, 


13 . 


69, 


13. 


90, 


14. 


09, 


14. 


26, 


14 . 


40, 


14 . 


52, 


14 . 


62, 




# 


14. 


71, 


14 . 


79, 


14 . 


85, 


14 . 


88, 


14 . 


89, 


14. 


87, 


14 . 


84, 


14 . 


79, 


14 . 


73, 




# 


14. 


69, 


14 . 


66, 


14 . 


65, 


14 . 


65, 


14 . 


68, 


14 . 


72, 


14 . 


77, 


14 . 


81, 


14 . 


86, 




# 


-14 . 


87, 


14 . 


87, 


14 . 


86, 


14 . 


82, 


14. 


78, 


14. 


72, 


14 . 


66, 


14 . 


59, 


14 . 


51, 






14 . 


43, 


14 . 


35, 


14 . 


25, 


14 . 


15, 


14 . 


05, 


13. 


93, 


13 . 


81, 


13 . 


67, 


13 . 


52, 


1 y 


# 


13. 


37, 


13 . 


22, 


13 . 


08, 


12 . 


97, 


12. 


89, 


12. 


84, 


12 . 


81, 


12. 


78, 


12 . 


75, 




# 


12. 


69, 


12 . 


60, 


12. 


49, 


12 . 


36, 


12 . 


21, 


12. 


05, 


11 . 


92, 


11 . 


85, 


11 . 


85/ 



DATA {CUT0FF(16, J) , J=l, 72) / 

^ # 12.94, 13.03, 13.14, 13.27, 

%J # 14.41, 14.64, 14.88, 15.10, 

# 15.97, 16.03, 16.07, 16.07, 

# 15.68, 15.61, 15.54, 15.50, 

# 15.35, 15.31, 15.25, 15.17, 

# 14.62, 14.51, 14.40, 14.28, 

# 13.36, 13.21, 13.08, 12.99, 

# 13.09, 13.08, 13.05, 13.00, 
DATA {CUT0FF(17, J) , J=l, 72) / 

# 13.80, 13.93, 14.07, 14.22, 

# 15.34, 15.56, 15.78, 16.00, 

# 16.87, 16.91, 16.92, 16.90, 

# 16.31, 16.18, 16.07, 15.97, 

# 15.53, 15.44, 15.35, 15.25, 

# 14.60, 14.48, 14.35, 14.21, 

# 13.14, 12.98, 12.86, 12.80, 

# 13.32, 13.40, 13.45, 13.48, 
DATA (CUT0FF{18, J) , J=l,72) / 

# 14.41, 14.56, 14.72, 14.88, 

# 15.94, 16.14, 16.36, 16.57, 

# 17.41, 17.43, 17.42, 17.38, 

# 16.61, 16.45, 16.30, 16.15, 

# 15.43, 15.31, 15.19, 15.07, 



13 


.42, 


13 


.58, 


13 


.77, 


13 


.97, 


14 


.18, 


15 


.30, 


15 


.48, 


15 


.64, 


15 


.77, 


15, 


.88, 


16 


.05, 


16 


.01, 


15 


.94, 


15 


.86, 


15. 


.77, 


15 


.46, 


15 


.44, 


15 


.42, 


15 


.41, 


15. 


.39, 


15, 


.09, 


15 


.01, 


14 


.92, 


14 


.82, 


14. 


.72, 


14. 


.15, 


14 


.01, 


13 


.86, 


13 


:7o, 


13. 


.53, 


12. 


.95, 


12 


.95, 


12 


.98, 


13 


.03, 


13. 


.07, 


12. 


.93, 


12 


.88, 


12 


.85, 


12 


.84, 


12 . 


,87/ 


14. 


,38, 


14 , 


.55, 


14 , 


.73, 


14 , 


.92, 


15. 


12, 


16. 


,21, 


16. 


.39, 


16, 


.56, 


16. 


.69, 


16. 


79, 


16. 


85, 


16. 


.77, 


16. 


.67, 


16, 


.56, 


16. 


43, 


15. 


89, 


15. 


.81, 


15. 


.74, 


15. 


.67, 


15. 


60, 


15. 


15, 


15, 


.04, 


14 . 


93, 


14 . 


,83, 


14 . 


71, 


14. 


06, 


13. 


.89, 


13 . 


.71, 


13 . 


,52, 


13. 


32, 


12. 


80, 


12. 


,87, 


12, 


97, 


13 . 


09, 


13. 


21, 


13. 


50, 


13 . 


52, 


13 , 


55, 


13 . 


61, 


13. 


69/ 


15. 


05, 


15. 


21, 


15. 


38, 


15. 


56, 


15. 


74, 


16. 


77, 


16. 


95, 


17. 


11, 


17. 


25, 


17. 


34, 


17. 


30, 


17. 


20, 


17. 


07, 


16. 


93, 


16. 


77, 


16. 


01, 


15. 


89, 


15. 


77, 


15. 


66, 


15. 


55, 


14 . 


96, 


14 . 


84, 


14 . 


73, 


14 . 


61, 


14. 


49, 



□ 



# 


14 


.36, 


i4^r 


14 


. 08 


, 13 


. 92, 


13 


.72, 


13 


. 51, 




722, 


12 


.99, 


12 


.71, 


# 


12 


.45, 


12.34, 


12 


.34 


, 12 


.29, 


12 


.41, 


12 


. 55, 


12 


.73, 


12 


.93, 


13 


.14, 


# 


13 


.33, 


13.50, 


13 


.64 


/ 13 


.76, 


13 


.85, 


13 


. 94, 


14 


.04, 


14 


.14, 


14 


.27/ 




DATA (CUTOFF{19, J) , J 


=1,72)/ 






















# 


14 


. 70, 


14 . 86, 


15 


. 02 


, 15 


■ 19, 


15 


.35, 


15 


. 51, 


15 


.67, 


15 


.82, 


15 


.99, 


# 


16 


• 17, 


16 . 35, 


16 


. 55 


/ 16 


. 75, 


16 


. 95, 


17 


. 13, 


17 


.29, 


17 


.42, 


17 


.52, 


# 


17 


.57, 


17.59, 


17 


.56 


, 17 


.50, 


17 


.41, 


17 


.29, 


17 


.15, 


16 


. 99, 


16 


.81, 


# 


16 


.63, 


16.44, 


16 


.25 


, 16 


.06, 


15 


. 89, 


15 


. 72, 


15 


.56, 


15 


.41, 


IS 


.25, 


# 


15 


.10, 


14.96, 


14 


.81 


, 14 


.68, 


14 


. 55, 


14 


.42, 


14 


.30, 


14 


.18, 


14 


.03, 


# 


13 


.88, 


13.74, 


13 


.56 


, 13 


.35, 


13 


. 13, 


12 


.75, 


12 


.36, 


12 


.00, 


11 


.59, 


# 


11 


.27, 


11.05, 


10 


.96 


, 11 


.06, 


11 


.41, 


11 


. 85, 


12 


.22, 


12 


.53, 


12 


.83, 


# 


13 


.11, 


13.36, 


13 


.58 


, 13 


.78, 


13 


. 95, 


14 


. 10, 


14 


.25, 


14 


.39, 


14 


.54/ 




DATA (COTOFF(2 0, J) , J: 


= 1,72)/ 






















# 


14 


.63, 


14.79, 


14 


95 


r 15 


. 10, 


15 


,25, 


15 


.40, 


15 


.54, 


15 


.68, 


15 


.83, 


# 


15 


.99, 


16 .16, 


16 


34 


r 16 


.54, 


16 


.73, 


16 


. 91, 


17 


. 07, 


17 


.20, 


17 


.29, 


# 


17 


.35, 


17.36, 


17 


34 


17 


.27, 


17 


. 18, 


17 


. 06, 


16 


.91, 


16 


. 75, 


16 


.56, 


# 


16 


.37, 


16.16, 


15 


95 


15 


. 75, 


15 


. 54, 


15 


. 34, 


15 


.14, 


14 


. 95, 


14 


.77, 


# 


14 


.59, 


14 .41, 


14 


25 


14 


.09, 


13 


. 95, 


13 


. 81, 


13 


.67, 


13 


.52, 


13 


.35, 


# 


13 


.19, 


12.99, 


12 


77 


12 


.46, 


12 


. 06, 


11 


. 60, 


11 


.05, 


10 


.41, 


9 


.86, 


# 


9 


.27, 


8 .69, 


8 


41 


8 


.64, 


9 


. 15, 


10 


. 07, 


11 


. 01, 


11 


■ 75, 


12 


.22, 


# 


12 


.60, 


12 . 94, 


13. 


24 


13 


.50, 


13 


. 73 , 


13 


. 94, 


14 


.12, 


14 


.30, 


14 


.46/ 




DATA (CUTOFF (21, J) 


/ J= 


= 1,72) / 






















# 


14 


.17, 


14.32, 


14 . 


47, 


14 


61, 


14 


. 74, 


14 


. 87, 


14 


99, 


15 


.12, 


15 


.25, 


# 


15 


39, 


15.55, 


15. 


72, 


15 


91, 


16 


.09, 


16 


.27, 


16 


43, 


16 


57, 


16 


.67, 


# 


16 


73, 


16 .75, 


16 . 


73, 


16 


68, 


16 


.60, 


16 


49, 


16 


36, 


16 


21, 


16 


.03, 


# 


15 


85, 


15.64, 


15. 


43, 


15 


21, 


14 


. 99, 


14 


76, 


14 


54, 


14 


32, 


14 


.11, 


# 


13 


90, 


13.70, 


13. 


51, 


13 


33, 


13 


. 16, 


13 


00, 


12 


84, 


12 


64, 


12 


.45, 


# 


12 


23, 


11.96, 


11. 


67, 


11 


32, 


10 


.89, 


10 


28, 


9 


35, 


8 


60, 


8 


31, 


# 


7 


67, 


7.15, 


6. 


79, 


6 


61, 


7 


.24, 


8 


16, 


8 


49, 


9 


68, 


10 


89, 


# 


11 


67, 


12 .18, 


12. 


55, 


12 


88, 


13 


. 17, 


13 


42, 


13 


63, 


13 


83, 


14 


00/ 




DATA (CUTOFF (2 2, J) 


, J= 


= 1,72)/ 






















# 


13 


25, 


13.38, 


13. 


53, 


13 


68, 


13 


. 81, 


13 


92, 


14 


03, 


14 


14, 


14 


25, 


# 


14 


38, 


14.52, 


14. 


68, 


14 


86, 


15 


. 04 , 


15 


22, 


15. 


37, 


15. 


52, 


15 


62, 


# 


15 


69, 


15.73, 


15. 


73, 


15 


70, 


15 


.65, 


15 


57, 


15, 


47, 


15. 


36, 


15 


22, 


# 


15 


05, 


14.87, 


14. 


67, 


14 


46, 


14 


.23, 


14 


00, 


13 . 


76, 


13 . 


52, 


13 


28, 


# 


13 


04, 


12 .81, 


12. 


58, 


12 . 


38, 


12 


17, 


11 


96, 


11. 


74, 


11, 


49, 


11 


21, 


# 


10, 


88, 


10.53, 


10. 


10, 


9. 


63, 


9 


06, 


8 


44, 


7. 


74, 


7 , 


09, 


6 


49, 


# 


6 . 


02, 


5.69, 


5. 


59, 


5. 


51, 


5 


78, 


6 , 


15, 


7. 


02, 


8 . 


04, 


9. 


04, 


# 


9. 


98, 


10.81, 


11. 


34, 


11. 


78, 


12 


14, 


12 . 


42, 


12. 


68, 


12 . 


90, 


13. 


07/ 




DATA (CUTOFF (2 3, J) 


, J= 


:1,72)/ 






















# 


11. 


49, 


11.62, 


11. 


74, 


11. 


83, 


11 


91, 


11 . 


98, 


12. 


10, 


12. 


19, 


12. 


35, 


# 


12. 


51, 


12.67, 


12 . 


83, 


13. 


09, 


13 


34, 


13 . 


59, 


13. 


82, 


14 . 


00, 


14. 


11, 


# 


14 . 


19, 


14.27, 


14 . 


30, 


14. 


31, 


14 


31, 


14. 


28, 


14 . 


23, 


14 . 


17, 


14. 


08, 


# 


13 . 


97, 


13 .82, 


13. 


66, 


13. 


46, 


13 


25, 


13 . 


02, 


12 . 


75, 


12 . 


43, 


12. 


07, 


# 


11. 


69, 


11.26, 


10. 


79, 


10. 


48, 


10 


14, 


9. 


80, 


9. 


65, 


9. 


41, 


9. 


10, 


# 


8 . 


78, 


8.25, 


7. 


62, 


6. 


99, 


6, 


40, 


5. 


97, 


5. 


54, 


5. 


08, 


4. 


74, 


# 


4 . 


38, 


4.19, 


4 . 


10, 


4 . 


02, 


4 , 


21, 


4 . 


61, 


5. 


14, 


5 . 


65, 


6. 


46, 


# 


7. 


54, 


8.64, 


9. 


38, 


10. 


02, 


10 . 


52, 


10. 


72, 


10. 


94, 


11. 


16, 


11. 


33/ 




DATA (CUTOFF (24, J) 


,J= 


1,72)/ 






















# 


9. 


77, 


9.75, 


9. 


86, 


9. 


74, 


9. 


76, 


9. 


84, 


10. 


01, 


10. 


17, 


10. 


27, 


# 


10. 


42, 


10.45, 


10. 


72, 


10. 


88, 


11 . 


20, 


11. 


37, 


11. 


27, 


11. 


33, 


11. 


34, 


# 


11. 


39, 


11.46, 


11. 


56, 


11. 


63, 


11. 


74, 


11. 


87, 


11. 


95, 


12 . 


08, 


12. 


17, 


# 


12 . 


18, 


12.09, 


11. 


92, 


11. 


69, 


11. 


37, 


11. 


04, 


10. 


67, 


10. 


31, 


9. 


93, 


# 


9. 


52, 


9.44, 


9. 


49, 


8. 


99, 


8. 


52, 


8. 


15, 


7. 


67, 


7 . 


07, 


6. 


56, 




6. 


11/ 


5.75, 


5 . 


48, 


5. 


17, 


4 . 


89, 


4. 


56, 


4 . 


21, 


3 . 


80, 


3. 


44, 




3. 


24, 


3 .08, 


2. 


98, 


2 . 


99, 


3 . 


13, 


3. 


41, 


3. 


83, 


4 . 


15, 


4. 


74, 




5. 


26, 


5.76, 


6. 


45, 


7. 


36, 


8 . 


14, 


8. 


72, 


9. 


11, 


9. 


38, 


9. 


59/ 




DATA (CUTOFF (25, J) 


, J= 


1,72)/ 






















# 


6. 


95, 


7.19, 


7 . 


34, 


7. 


44, 


7 . 


50, 


7 . 


52, 


7. 


59, 


7. 


58, 


7. 


63, 




7. 


73, 


7.83, 


7 . 


91, 


8. 


07, 


8 . 


24, 


8. 


38, 


8. 


54, 


8. 


71, 


8. 


87, 





8 


.99, 


9^^, 


9.13, 


# 


9 


.99, 


10.01, 


9.99, 




7 


.96, 


7.41, 


6.90, 


# 


4 


.60, 


4.34, 


4.02, 


# 


2 


.14, 


2.09, 


2.04, 


# 


3 


.79, 


4 . 18, 


4 .63, 




DATA {CUTOFF{26, J) , J= 


# 


4 


.99, 


5.02, 


5.09, 


# 


5 


.44, 


5.52, 


5.53, 


# 


6, 


.08, 


6.16, 


6.19, 




6. 


.96, 


7.03, 


6.99, 


# 


5. 


.60, 


5.35, 


5.03, 




3 . 


.16, 


2.92, 


2.66, 


# 


1. 


.35, 


1.28, 


1.25, 


# 


2. 


47, 


2 .71, 


3.06, 




DATA (CUTOFF(27, J) , J=: 


# 


3. 


32, 


3 .35, 


3.49, 


# 


3. 


94, 


3.97, 


4.03, 


# 


4 . 


34, 


4.36, 


4.44, 




5. 


00, 


5.05, 


4 .98, 


# 


4 . 


25, 


4 .08, 


3.78, 


# 


2 . 


05, 


1.79, 


1.64, 


# 


0. 


75, 


0.71, 


0.72, 


# 


1. 


43, 


1.67, 


1.92, 



DATA (CUTOFF{28, J) , J=l 





# 


2.00, 


2 


.08, 


2 


.26, 




# 


2.53, 


2 


.64, 


2 


.64, 




# 


2 .84, 


2 


.80, 


2 


.86, 




# 


3.31, 


3 


.38, 


3 , 


.38, 




# 


2 .85, 


2 , 


.69, 


2. 


.49, 


Lii 


# 


1.23, 


1, 


.07, 


0. 


.90, 




# 


0.36, 


0. 


.36, 


0. 


.35, 




# 


0.80, 


0, 


93, 


1 . 


.05, 



DATA {CUTOFF(29, J) , J=l 



u 
n 


1 


.16, 


1 


.23, 


1, 


.29, 


# 


1 


.59. 


1 


.60, 


1, 


.57, 


# 


1' 


.70, 


1. 


.74, 


1. 


.73, 


» 


2 


.05, 


2 , 


.09, 


2. 


.09, 


# 


1 


.76, 


1, 


.63, 


1. 


.55, 


# 


0 


.65, 


0, 


.56, 


0. 


.46, 


# 


0 


.16, 


0. 


.15, 


0. 


15, 


# 


0 


.39, 


0. 


.44, 


0. 


53, 



DATA (CUTOFF{30, J) , J=l 



# 


0 


.60, 


0 


.62, 


0.66, 


# 


0 


.87, 


0 


.90, 


0.88, 


# 


0 


.98, 


1 


.00, 


1.06, 


# 


1, 


.23, 


1 


.14, 


1.22, 


# 


0 


.99, 


0 


.90, 


0.83, 


# 


0, 


.31, 


0. 


.26, 


0.21, 


# 


0. 


.05, 


0, 


.05, 


0.05, 


# 


0, 


.17, 


0, 


.20, 


0.25, 




DATA (CUT0FF(31, J) , J= 




0, 


.27, 


0. 


.29, 


0.31, 


# 


0. 


44, 


0. 


.45, 


0.47, 




0. 


.51, 


0. 


.54, 


0.56, 


# 


0. 


60, 


0, 


,62, 


0.61, 


# 


0. 


47, 


0, 


45, 


0.38, 


# 


0. 


13, 


0. 


10, 


0.08, 


# 


0. 


00, 


0, 


00, 


0.00, 


# 


0. 


06, 


0. 


07, 


0.09, 




9.23, 


9 


.30, 


9 


.46, 


9 


.57, 


9 


.79, 


9.90, 


9.82, 


9 


.63, 


9 


.37, 


9 


.05, 


8 


.64, 


8.31, 


6.47, 


6 


.08, 


5 


.78, 


5 


.49, 


5 


.27, 


4.89, 


3.63, 


3 


.30, 


3 


.08, 


2 


.77, 


2 


.54, 


2.30, 


2 .05, 


2 


.13, 


2 


.27, 


2 


.57, 


2 


. 86, 


3.22, 


5. 08, 
,72)/ 


5 


.41, 


5 


.76, 


6 


.15, 


6 


.42, 


6 .72/ 


5.20, 


5 


.21, 


5 


.34, 


5 


.35, 


5 


.36, 


5.32, 


5.66, 


5 


.71, 


5 


.73, 


5 


.81, 


5 


.98, 


6.03, 


6.31, 


6 


.37, 


6 


.45, 


6 


.59, 


6 


.75, 


6 .85, 


6.96, 


6 


.88, 


6 


.66, 


6 


.38, 


6 


.17, 


5.83, 


4.85, 


4 


.59, 


4 


.40, 


4 


.15, 


3 


.77, 


3.47, 


2.37, 


2 


.10, 


1 


.88, 


1 


.75, 


1 


.58, 


1.45, 


1.27, 


1 


.36, 


1 


.47, 


1 


.62, 


1 


.87, 


2.11, 


3.35, 
,72)/ 


3 


.80, 


4 


.17, 


4 


.35, 


4 


.61, 


4.68/ 


3.59, 


3 


.69, 


3 


.76, 


3 


.83, 


3 


.86, 


3.91, 


4.06, 


4 


.11, 


4 


.17, 


4 


.20, 


4 


.32, 


4.32, 


4.45, 


4 


.49, 


4 


.64, 


4 


.69, 


4 


.85, 


5.00, 


4.97, 


4 


.86, 


4 


.77, 


4 


.69, 


4 


.54, 


4.47, 


3.46, 


3 


.21, 


3 


.00, 


2 


.81, 


2 


.51, 


2 .25, 


1.42, 


1 


.28, 


1 


.11, 


0 


.98, 


0 


.87, 


0.81, 


0.73, 


0 


.79, 


0 


.87, 


0 


.95, 


1 


.10, 


1.27, 


2.13, 
,72)/ 


2 


.33, 


2 


.65, 


2 


.85, 


2 


.96, 


3.18/ 


2.29, 


2 


.36, 


2 


.41, 


2 


.45, 


2 


.47, 


2.51, 


2.67, 


2 


.68, 


2 


.69, 


2 


.73, 


2 


.77, 


2.78, 


2.93, 


2 


.93, 


3 


.03, 


3 


.12, 


3 


.19, 


3.26, 


3.31, 


3 


.30, 


3 


.26, 


3 


.15, 


3 


. 08, 


3.02, 


2.28, 


2 


.18, 


1, 


.96, 


1 , 


.75, 


1 , 


.55, 


1.37, 


0.81, 


0. 


.70, 


0. 


.58, 


0. 


.49, 


0 , 


.44, 


0.41, 


0.36, 


0. 


.38, 


0. 


.46, 


0. 


.50, 


0. 


.58, 


0.68, 


1.21, 
72)/ 


1. 


.35, 


1. 


.54, 


1 . 


.70, 


1 . 


.81, 


1. 96/ 


1.36, 


1 . 


39, 


1, 


.44, 


1 . 


.43, 


1 . 


.52, 


1.54, 


1.62, 


1 . 


,64, 


1 . 


,69, 


1 . 


68, 


1, 


,67, 


1.69, 


1.80, 


1. 


86, 


1, 


89, 


1. 


96, 


1 . 


99, 


2.06, 


2.12, 


2. 


14, 


2 . 


04, 


2 . 


06, 


1 . 


96, 


1.86, 


1.38, 


1. 


27, 


1. 


16, 


0. 


98, 


0. 


89, 


0. 77, 


0.40, 


0. 


32, 


0. 


27, 


0. 


23, 


0. 


20, 


0.17, 


0.16, 


0. 


17, 


0. 


21, 


0. 


23, 


0. 


27, 


0.34, 


0.64, 
72)/ 


0. 


72, 


0. 


85, 


0. 


90, 


1. 


00, 


1.09/ 


0.69, 


0. 


76, 


0. 


77, 


0 . 


80, 


0. 


82, 


0.87, 


0.91, 


0. 


93, 


0. 


94, 


0. 


94, 


0 . 


98, 


0.98, 


1.03, 


1. 


04, 


1. 


09, 


1 . 


12, 


1. 


14, 


1.16, 


1.18, 


1. 


18, 


1. 


18, 


1. 


11, 


1 . 


09, 


1.02, 


0.77, 


0. 


68, 


0. 


57, 


0. 


49, 


0. 


45, 


0.39, 


0.17, 


0. 


13, 


0. 


10, 


0. 


09, 


0. 


07, 


0.06, 


0.05, 


0. 


06, 


0. 


07, 


0. 


09, 


0. 


11, 


0.14, 


0.30, 
72)/ 


0. 


33, 


0. 


38, 


0. 


43, 


0. 


50, 


0.54/ 


0.34, 


0. 


36, 


0. 


38, 


0 . 


39, 


0 . 


42, 


0.41, 


0.48, 


0. 


49, 


0. 


48, 


0. 


51, 


0. 


51, 


0.50, 


0.55, 


0. 


55, 


0. 


56, 


0. 


58, 


0. 


57, 


0.58, 


0.61, 


0. 


59, 


0. 


57, 


0. 


57, 


0 . 


53, 


0.51, 


0.34, 


0. 


30, 


0. 


27, 


0. 


23, 


0. 


19, 


0.16, 


0.06, 


0. 


04, 


0. 


02, 


0. 


00, 


0. 


00, 


0.00, 


0.00, 


0. 


00, 


0. 


00, 


0. 


00, 


0. 


02, 


0.04, 


0.11, 


0. 


14, 


0. 


16, 


0. 


19, 


0. 


22, 


0.25/ 



c 
c 





DATIl (n 




^32, Jl 




1, 72) / 






















u 

it 


c\ in 


U 


. X J. , 


u 


. 13 , 


0.14, 


0 


. 15, 


0 


. 16, 


0 


.17, 


0 




0 


.19, 


u 


n 


U 


O 1 


u , 


, 2,Z , 


0 . 22 , 


0 


.23, 


0 


.24, 


0 


.22, 


0 


.24, 


0 


.24, 


a 


n "jc. 


u 


, , 


U , 


. 25 , 


0.25, 


0 


. 26 , 


0 


.28, 


0 


.26, 


0 


.27, 


0 


.27, 


# 
Tt 


U . ^ D 1 




. Z / , 


r\ 

U . 


. 27 , 


A O C 

U . 26 , 


0 


.25, 


0 


.25, 


0 


.24, 


0 


.22, 


0 


.20, 


it 


U.J.:?, 




. lb , 


U . 


15 , 


0 . 14 , 


0 


.12, 


0 


.10, 


0 


.09, 


0 


.07, 


0 


.05, 


U 

TT 




u 


. 02, 


0, 


, UtJ , 


0 . 00 , 


0 


. 00, 


0 


.00, 


0 


. 00, 


0 


.00, 


0 


. 00, 


ff 


0. 00, 


0. 


. 00, 


0. 


, 00 , 


0.00, 


0 


.00, 


0 


.00, 


0, 


.00, 


0 


.00, 


0, 


.00, 


U 
TT 


0.00, 


0. 


. 00, 


0. 


UU , 


0 . 02 , 


0 - 


. 04, 


0 , 


.05, 


0 . 


.07, 


0, 


.08, 


0, 


.09/ 




DATA (CUTOFF (33, J) 


, J = 


1 , 72) / 




















u 

Tf 


0.02, 


0. 


,03, 


0. 


04 , 


A AC 

0 . 05 , 


0 . 


.05, 


0 . 


.06, 


0 . 


, 06, 


0. 


.07, 


0, 


07, 


U 

it 


0.08, 


0. 


08, 


0. 


09, 


A A A 

0 - 09 , 


0 , 


09, 


0 . 


, 09, 


0 . 


09, 


0. 


,09, 


0, 


10, 


U 
# 


0.10, 


0. 


10, 


0. 


10, 


0.10, 


0 . 


,10, 


0 , 


,11, 


0 . 


11, 


0. 


11, 


0. 


10, 


U 
it 


0. 10, 


0. 


10, 


0. 


10, 


0.10, 


0 . 


09, 


0 . 


09, 


0 . 


08, 


0. 


08, 


0. 


07, 


U 
n 


0.07, 


0. 


06, 


0. 


04 , 


0,03, 


0 . 


02 , 


0 . 


01, 


0 . 


00, 


0. 


00, 


0. 


00, 


# 


0.00, 


0. 


00, 


0. 


00 , 




A 

u . 


on 


A 

u . 


An 
UU , 


A 

0 . 


A A 


0 . 


00, 


0 . 


00 , 


# 


0. 00, 


0. 


00, 


0. 


00, 


0.00, 


0. 


00, 


0. 


00, 


0. 


00, 


0. 


00, 


0. 


00, 


# 


0.00, 


0. 


00, 


0. 


00, 


0.00, 


0. 


00, 


0. 


00, 


0. 


00, 


0. 


01, 


0. 


01/ 



DATA CN,CS/ 0.05, 0.21/ 

INIGRID=.TRUE. 

RETURN 
END 

SUBROUTINE InitPreCalcs (RigBins) 
IMPLICIT NONE 



INTEGER I,J,Nrigs 
PARAMETER (Nrigs=1001) 



REAL RigBins (Nrigs) ,RIGPC(Nrigs) 

REAL PCGTFl (Nrigs) , PCGTF2 (Nrigs) , PCGTF3 (Nrigs) , PCGTF4 (Nrigs) 
COMMON/PreCalcCMN/PCGTFl , PCGTF2 , PCGTF3 , PCGTF4 



DATA (RIGPC (I) ,1 = 1,90)/ 



# 


0 


.000, 


0 


.020, 


0 


. 040, 


0 


.060, 


0 


.080, 


0 


.100, 


0 


. 120, 


0 


.140, 


0 


.160, 


# 


0 


.180, 


0 


.200, 


0 


.220, 


0 


.240, 


0 


.260, 


0 


.280, 


0 


.300, 


0 


.320, 


0 


.340, 


# 


0 


.360, 


0 


.380, 


0 


.400, 


0 


.420, 


0 


.440, 


0 


.460, 


0 


.480, 


0 


.500, 


0 


.520, 


# 


0 


.540, 


0 


.560, 


0 


.580, 


0 


.600, 


0 


.620, 


0 


.640, 


0 


.660, 


0 


.680, 


0 


.700, 


# 


0 


.720, 


0 


.740, 


0 


.760, 


0 


. 780, 


0 


.800, 


0 


.820, 


0 


.840, 


0 


.860, 


0 


.880, 


# 


0 


.900, 


0 


.920, 


0 


.940, 


0 


.960, 


0 


.980, 


1 


. 000, 


1 


.020, 


1 


.040, 


1 


.060, 


# 


1 


.080, 


1. 


.100, 


1, 


.120, 


1. 


.140, 


1, 


.160, 


1 


.180, 


1 


.200, 


1 


.220, 


1 


.240, 


# 


1 


.260, 


1, 


.280, 


1, 


.300, 


1. 


.320, 


1, 


.340, 


1 


.360, 


1 


.380, 


1, 


.400, 


1 


.420, 


# 


1 


.440, 


1, 


.460, 


1. 


.480, 


1, 


.500, 


1. 


.520, 


1, 


.540, 


1 


.560, 


1, 


.580, 


1, 


.600, 


# 


1, 


.620, 


1. 


.640, 


1, 


.660, 


1. 


,680, 


1, 


.700, 


1. 


.720, 


1, 


. 740, 


1. 


.760, 


1, 


.780/ 




DATA (RIGPC (I) , 


,1= 


= 91,180)/ 


















# 


1 . 


.800, 


1. 


820, 


1. 


,840, 


1 . 


860, 


1, 


.880, 


1. 


. 900, 


1 . 


.920, 


1 . 


, 940, 


1, 


, 960, 


# 


1 , 


.980, 


2. 


,000, 


2 . 


020, 


2. 


040, 


2. 


,060, 


2 , 


.080, 


2 . 


.100, 


2 . 


, 120, 


2 . 


,140, 


# 


2. 


,160, 


2. 


180, 


2. 


200, 


2. 


220, 


2. 


,240, 


2 . 


,260, 


2 . 


280, 


2 . 


300, 


2 . 


320, 


# 


2, 


340, 


2. 


360, 


2. 


380, 


2 . 


400, 


2. 


420, 


2, 


440, 


2 . 


460, 


2 . 


480, 


2. 


500, 


# 


2. 


520, 


2. 


540, 


2. 


560, 


2. 


580, 


2. 


600, 


2 . 


620, 


2 . 


640, 


2. 


660, 


2 . 


680, 


# 


2 . 


700, 


2. 


720, 


2 . 


740, 


2 . 


760, 


2 . 


780, 


2 . 


800, 


2 . 


820, 


2 . 


840, 


2 . 


860, 


# 


2. 


880, 


2. 


900, 


2. 


920, 


2. 


940, 


2. 


960, 


2 . 


980, 


3 . 


000, 


3 . 


020, 


3. 


040, 


# 


3 . 


060, 


3. 


080, 


3. 


100, 


3 . 


120, 


3. 


140, 


3 . 


160, 


3 . 


180, 


3 . 


200, 


3. 


220, 


# 


3. 


240, 


3. 


260, 


3. 


280, 


3. 


300, 


3. 


320, 


3 . 


340, 


3 . 


360, 


3. 


380, 


3 . 


400, 



Til 



u 
n 


3 


.420, 


3.4^ 


W -3 


.460, 


3 .480, 


3 


. 500 , 


3 


. 520 , 


3 


^5^0, 


3 


. 560 , 


3 


. 580/ 




DATA (RIGPC(I) 


/ 1 


=181, 270) / 






















u 
n 




. 0 UU , 


1 C 0 A 


-J 


C A t\ 

. b4U , 


0 c ^ n 


3 


. 680 , 


3 


. 700 , 


3 


. 720 , 


3 


. 740 , 


3 


. 760, 


u 
ff 


J 


•7 Q n 


■7 Q n n 




0 0 A 


1 Q A n 
J . o40 , 


3 


. 860 , 


3 


. 880 , 


3 


. 900 , 


3 


. 920, 


3 


. 940, 


if 


-J 


. 7b U / 


1 Q Q n 


A 

4 


AAA 


A A 0 rt 

4,020, 


4 


. 040 , 


4 


. 060 , 


4 


. 080, 


4 


. 100, 


4 


. 120, 


u 
n 


A 


. X4 VJ , 


4 . Xb u , 


A 

4 


IDA 


4 . ^00 , 


4 


. 220 , 


4 


. 240 , 


4 


. 260, 


4 


. 280, 


4 


. 300, 


u 
# 


A 


1 0 A 


A 1 A n 

4 . J4 U , 


A 

4 


"5 C A 


A 0 0 A 

4 . J80 , 


4 


. 400 , 


4 


. 420, 


4 


.440, 


4 


.460, 


4 


.480, 


n 


A 

4 


c 


A con 


4 


tL A r\ 

. b40 , 


4.560, 


4 


. 580 , 


4 


. 600 , 


4 


. 620 , 


4 


. 640, 


4 


. 660, 




4 


.680, 


4.700, 


A 

4 


.720, 


4.740, 


4 


. 760 , 


4 


. 780 , 


4 


. 800 , 


4 


. 820, 


4 


. 840, 


# 


4 


.860, 


4.880, 


>• 
4 


. 900, 


4.920, 


4 


. 940 , 


4 


. 960, 


4 


. 980, 


5 


. 000, 


5 


. 020, 


ft 


5 


.040, 


5.060, 


c 


. 080, 


5.100, 


5 


. 120 , 


5 


. 140 , 


5 


. 160 , 


5 


. 180, 


5 


.200, 


ii 
ff 


5 


.220, 


5.240, 


c 
O 


.260, 


5.280, 


5 


. 300 , 


5 


. 320 , 


5 


. 340 , 


5 


. 360, 


5 


. 380/ 




DATA (RIGPC(I) 


T 


=271,360) / 






















XL 
# 


5 


.400, 


5.420, 


5 


.440, 


5.460, 


5 


. 480 , 


5 


. 500 , 


5 


. 520, 


5 


. 540, 


5 


. 560, 


ff 


5 


.580, 


5.600, 


5 


.620, 


5.640, 


5 


. 660 , 


5 


. 680 , 


5 


. 700 , 


5 


. 720, 


5 


. 740, 


41 
# 


5 


.760, 


5.780, 


c 
D 


.800, 


5.820, 


5 


, 840 , 


5. 


. 860, 


5 


. 880 , 


5 


. 900, 


5 


. 920, 


41 


5 


.940, 


5.960, 


c 


.980, 


6.000, 


6 


, 020 , 


6 


, 040 , 


6 


. 060 , 


6 


. 080, 


6 


. 100, 


IF 


6 


. 120, 


6 .140, 


c 
0 


.160, 


6.180, 


6 


. 200 , 


6 


, 220 , 


6 


. 240 , 


6 


. 260 , 


6 


.280, 


41 


6 


.300, 


6.320, 


c_ 

D 


.340, 


6.360, 


6 


. 380 , 


6 


.400, 


6 


. 420 , 


6 


. 440, 


6 


.460, 


44 


6 


.480, 


6.500, 


c 
D 


.520, 


6.540, 


6 


. 560 , 


6 


. 580 , 


6 


. 600 , 


6 


. 620, 


6 


. 640, 


41 


6 


.660, 


6.680, 


6 


.700, 


6.720, 


6 


. 740 , 


6 


, 760, 


6 


. 780, 


6 


. 800, 


6 


. 820, 


41 
# 


6 


.840, 


6.860, 


5 


.880, 


6. 900, 


6 


. 920 , 


6 


. 940 , 


6 


. 960 , 


6 


. 980, 


7 


. 000, 


44 


7 


.020, 


7.040, 


7 


.060, 


7.080, 


7 


. 100 , 


7 


. 120 , 


7 


. 140 , 


7 


. 160, 


7 


. 180/ 




DATA (RIGPCd) 


/ 1 = 


=361,450)/ 






















41 


7 


.200, 


7.220, 


7 


.240, 


7.260, 


7 , 


. 280 , 


7 


. 300 , 


7 


. 320 , 


7 


. 340, 


7 


.360, 


44 


7, 


.380, 


7.400, 


7 


.420, 


7.440, 


7 , 


. 460 , 


7 


. 480 , 


7 


. 500 , 


7 


. 520, 


7 


. 540, 


44 


7, 


.560, 


7.580, 


7 


.600, 


7.620, 


7 . 


. 640 , 


7 


. 660 , 


7 


. 680 , 


7 


. 700, 


7 


. 720, 


44 
IF 


7, 


.740, 


7.760, 


7 , 


.780, 


7.800, 


7 , 


. 820 , 


7 , 


. 840 , 


7 


. 860 , 


7 


. 880, 


7 


. 900, 


44 
?F 


7, 


.920, 


7.940, 


7 , 


.960, 


7.980, 


8 . 


. 000 , 


8 , 


. 020 , 


8 


. 040 , 


8 , 


. 060, 


8 , 


. 080, 


44 
?F 


8. 


.100, 


8.120, 


0 

0 . 


.140, 


8 . 160, 


8 , 


. 180 , 


8 , 


. 200 , 


8 , 


. 220 , 


8 , 


. 240, 


8 , 


. 260, 


41 
# 


8. 


.280, 


8.300, 


8 , 


.320, 


8.340, 


8 . 


. 360 , 


8 , 


. 380, 


8 , 


.400 , 


8 , 


.420, 


8 . 


.440, 


41 


8. 


,460, 


8 .480, 


8 . 


. 500, 


8 . 520, 


8 . 


. 540 , 


8 , 


. 560, 


8 . 


. 580 , 


8 , 


.600, 


8 . 


. 620, 


44 
?F 


8. 


,640, 


8.660, 




.680, 


8 . 700, 


8 , 


. 720 , 


8 . 


, 740 , 


8 . 


. 760 , 


8 . 


. 780, 


8 , 


, 800, 


44 
IF 


8. 


,820, 


8.840, 


0 

0 . 


.860, 


8.880, 


8 , 


, 900 , 


8 , 


. 920 , 


8 . 


. 940 , 


8 , 


. 960 , 


8 . 


. 980/ 




DATA (RIGPCd) 


, 1 = 


=451,540)/ 






















+F 


9. 


,000, 


9.020, 




040, 


9.060, 


9 . 


080 , 


9 . 


, 100 , 


9 . 


. 120 , 


9 , 


, 140, 


9. 


, 160, 


44 
FF 


9. 


180, 


9.200, 


9 , 


,220, 


9.240, 


9 . 


260 , 


9 , 


,280, 


9 . 


. 300 , 


9 . 


, 320, 


9 . 


340, 


44 
FF 


9. 


360, 


9.380, 


9 . 


400, 


9.420, 


9 . 


440 , 


9 . 


460 , 


9 . 


.480, 


9 . 


, 500, 


9. 


520, 


u 
FF 


9. 


540, 


9.560, 


Q 

9 . 


580, 


9.600, 


9 , 


620, 


9. 


640, 


9. 


,660, 


9. 


680, 


9. 


700, 


44 
n 


9. 


720, 


9.740, 


9. 


760, 


9.780, 


9. 


800, 


9. 


820, 


9. 


,840, 


9. 


860, 


9. 


880, 


FF 


9. 


900, 


9.920, 


9. 


940, 


9.960, 


9. 


980, 10. 


000,10. 


020,10. 


040,10. 


060, 


44 
FF 


10. 


080, 10.100, 10. 


120,10.140,10. 


160,10. 


180,10. 


200, 10. 


220, 10. 


240, 


44 
FF 


10. 


260,10.280,10. 


300,10.320,10. 


340, 10. 


360, 10. 


380, 10. 


400, 10. 


420, 


44 
FF 


10. 


440,10.460,10. 


480,10.500, 10. 


520, 10. 


540,10, 


560, 10. 


580, 10. 


600, 


44 
FF 


10. 


620, 10.640, 10. 


660, 10.680, 10. 


700, 10. 


720,10. 


740, 10. 


760, 10. 


780/ 




DATA (RIGPC(I) , 


, 1 = 


= 541,630)/ 






















u 
FF 


10. 


800,10.820,10. 


840,10.860,10. 


880, 10. 


900, 10. 


920, 10. 


940,10. 


960, 


44 
FF 


10. 


980, 11.000, 11 . 


020, 11.040, 11. 


060, 11. 


080, 11. 


100, 11. 


120, 11. 


140, 


u 
n 


11. 


160,11.180,11. 


200,11.220,11. 


240, 11. 


260,11. 


280, 11. 


300,11. 


320, 


4; 
FF 


11. 


340,11.360,11. 


380,11.400,11. 


420,11. 


440,11. 


460, 11. 


480,11. 


500, 


u 
FF 


11. 


520,11.540,11. 


560,11.580,11. 


600, 11. 


620, 11. 


640, 11. 


660, 11. 


680, 


FF 


11. 


700,11.720,11. 


740,11.760,11. 


780,11. 


800,11. 


820, 11. 


840,11. 


860, 


44 

FF 


11. 


880,11.900,11. 


920,11.940,11. 


960,11. 


980,12. 


000,12. 


020,12. 


040, 


FF 


12 . 


060,12.080,12. 


100,12.120,12. 


140, 12. 


160, 12 . 


180, 12. 


200,12. 


220, 


FF 


12. 


240,12.260,12. 


280,12.300,12. 


320,12. 


340, 12 . 


360,12. 


380,12. 


400, 


FF 


12. 


420,12.440,12. 


460,12.480,12. 


500,12. 


520,12. 


540,12. 


560,12. 


580/ 




DATA (RIGPC(I) , 1= 


631, 720) / 






















tF 


12. 


600,12.620,12. 


640,12.660,12. 


680, 12 . 


700,12. 


720, 12 . 


740, 12 . 


760, 


# 


12. 


780, 12 .800, 12 . 


820,12.840,12. 


860, 12. 


880, 12 . 


900, 12 . 


920, 12 . 


940, 


# 


12. 


960,12.980, 13. 


000, 13.020,13. 


040, 13. 


060,13. 


080, 13 . 


100,13. 


120, 



# 13. 140, 13. ^^13. 180, 13. 200, 13; 220, 13.240,1^^0,13.280,13.300, 

# 13.32 0, 13.340, 13 . 360, 13 . 380, 13 . 400, 13 . 420, 13 . 440, 13 . 460, 13 . 480, 

# 13.500, 13.520,13.540,13.560,13.580, 13.600,13.620,13.640,13.660, 

# 13.680, 13.700,13.720,13.740,13.760,13.780, 13.800,13.820,13.840, 

# 13.860,13.880,13.900,13.920,13.940,13.960,13.980,14.000,14.020, 

# 14.040, 14.060, 14.080,14.100,14.120, 14.140,14.160,14.180,14.200, 

# 14.220, 14.240, 14 . 260 , 14 . 280, 14 . 300 , 14 . 320 , 14 . 340 , 14 . 360 , 14 . 380/ 
DATA (RIGPCd) ,1 = 721,810)/ 

# 14.400, 14 .420, 14.440, 14.460, 14.480, 14 . 500, 14 . 520 , 14 . 540 , 14 . 560 , 

# 14.580, 14.600,14.620,14.640,14.660,14.680,14. 700,14.720,14.740, 

# 14.760,14.780,14.800,14.820,14.840,14.860,14.880,14.900,14.920, 

# 14.940,14.960,14.980,15.000,15.020,15.040,15. 060,15.080,15.100, 

# 15.120, 15.140,15.160,15.180, 15 . 200 , 15 . 220 , 15 . 240 , 15 . 260 , 15 . 280 , 

# 15.300, 15.320, 15.340,15.360,15.380, 15 .400, 15.420, 15.440, 15.460, 

# 15.480,15.500,15.520,15.540,15.560,15.580,15.600,15.62 0,15.640, 

# 15.660, 15.680,15.700,15.720,15.740,15.760,15.780, 15.800,15.820, 

# 15.84 0,15.860,15.880,15.900,15.920,15.94 0, 15. 960,15. 980,16.000, 

# 16 . 020, 16 . 040, 16. 060, 16 . 080, 16 . 100, 16 . 120, 16 . 140, 16 . 160, 16. 180/ 
DATA (RIGPC (I) ,1=811,900)/ 

# 16.200, 16.220,16.24 0,16.260,16.280,16 .300,16.32 0, 16.34 0,16.36 0, 

# 16.380,16.4 00,16.420,16.440,16.460,16.480,16. 500, 16.520,16.54 0, 

# 16.560, 16.580,16.600,16.620,16.640,16.660,16 .680, 16.700, 16.72 0, 

# 16.74 0,16.760,16.780, 16.800,16.820,16 .84 0,16.860, 16.880,16.900,. 

# 16.920, 16.940,16.960,16.980,17.000,17.020,17.040, 17.060,17.08 0, 
y # 17.100, 17.120,17.140,17.160,17.180,17.200,17.220, 17.240,17.260, 
^ # 17.280, 17.300,17.320,17.340,17,360,17.380,17.4 00,17.42 0,17.44 0, 
y # 17.460,17.480,17.500,17.520,17.540,17.560,17.580,17.600,17.62 0, 
y # 17.64 0, 17.660,17.680,17.700,17.720,17.74 0,17.760,17.780,17.800, 
rU # 17.820,17.840,17.860,17.880,17,900,17.920,17.940,17.960,17.98 0/ 
Q DATA (RIGPC (I) , 1=901, 990) / 

W # 18 .000, 18 . 020, 18 . 04 0, 18 . 060, 18 . 080, 18 . 100, 18 . 120, 18 . 14 0, 18 . 16 0, 

M # 18.180,18.2 00, 18.220,18.240,18.260,18.280,18.300,18.32 0,18.340, 

s # 18 . 360, 18 . 380, 18 .4 00, 18 .420, 18 .440, 18 .460, 18 .48 0, 18 . 500, 18 .520, 

M-- # 18 . 540, 18 . 560, 18 . 58 0, 18 . 600, 18 .620, 18 . 64 0, 18 . 660, 18 .680, 18 . 700, 

rij # 18.720,18.740,18,760,18.780,18.800,18.820,18.840, 18.860,18.880, 

id # 18.900, 18.920,18.940,18.960,18.980,19.000, 19.020, 19.040,19.060, 

U # 19.080,19.100,19.120,19.140,19.160,19.180,19.200,19.220,19.240, 

[q # 19.260, 19.280,19,300,19.320,19.340, 19.36 0,19.380, 19.400,19.42 0, 

# 19.440, 19.460,19.480,19.500,19.520,19.540, 19.560, 19.580, 19.600, 

# 19.620,19.640, 19.660,19.680,19.700, 19.720, 19.74 0, 19.760,19.78 0/ 
DATA (RIGPC (I) ^ 1=991, Nrigs) / 

# 19.800,19.820,19.840,19.860,19.880,19.900, 19.92 0, 19.940,19.960, 

# 19.980,20.000/ 

DATA (PCGTFld) , 1 = 1, 50) / 

# 0 . OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 

# 0. OOOOE+00, 0.2139E-03, 0.5824E-03, 0.1253E-02, 0.2217E-02, 

# 0.3307E-02, 0.4387E-02, 0.54 75E- 02,0. 6627E- 02, 0.783 7E-02, 

# 0.9039E-02, 0.1019E-01, 0.1139E-01,0.1273E-01, 0.1424E-01, 

# 0.1583E-01, 0.1741E-01, 0.1889E-01, 0.2021E-01, 0.2132E-01, 

# 0.2230E-01,0.2319E-01,0.2404E-01,0.24 91E-01, 0. 2583E-01, 

# 0.2678E-01, 0.2778E-01,0.2881E-01,0.2 987E-01, 0. 3096E-01, 
. # 0.3209E-01,0.3323E-01, 0.3440E-01, 0.3558E-01, 0.3678E-01, 

# 0, 3799E- 01, 0.3921E- 01,0. 4044E- 01,0. 4167E- 01, 0.42 90E-01, 

# 0.4413E-01, 0.4535E-01, 0 .4657E-01, 0.4 777E-01, 0 . 4896E-01/ 
DATA (PCGTFl (I) ,1=51,100)/ 

# 0.5014E-01,0.5129E-01, 0.5242E-01,0.5352E-01, 0. 5460E-01, 

# 0.5565E-01,0.5668E-01,0.5769E-01, 0. 5867E-01, 0.5963E-01, 

# 0.6057E-01,0.614 9E-01,0.6239E-01,0.6327E-01, 0.6414E-01, 

# 0 .6500E-01, 0.6584E-01, 0.6666E-01, 0.6748E-01, 0. 6828E-01, 



0.6908E-0I^6986E-01, 0.7064E-01,0.7141E-01^.7218E-01, 

0.7294E-01,0.7370E-01,0.7446E-01,0.7522E-01,0.7597E-01,' 

0.7673E-01,0.7749E-01,0.7825E-01,0.7902E-01,0.7979E-01,' 

0.8057E-01,0.8135E-01,0.8215E-01,0.8295E-01,0.8376E-Ol! 

0.8459E-01,0.8543E-01,0.8628E-01,0.8715E-01,0.8803E-0li 

0.8894E-01, 0.8985E-01,0.9079E-01, 0.9175E-01,0.9273E-01/ 
DATA (PCGTFl (I) ,1=101,150)/ 

0.9373E-01, 0.9475E-01,0.9579E-01,0.9684E-01,0.9791E-01, 
0.9900E-01, 0.1001E+00,0.1012E+00,0.1024E+00,0.1035E+Oo! 
0.1047E+00, 0.1059E + 00,0.1071E+00, 0.1083E+00, 0.1095E+00,' 
0.1107E+00, 0.1119E+00,0.1132E+00,0.1144E+00,0.1157E+00,' 
0.1170E+00, 0.1183E+00,0.1195E+00,0.1208E+00,0.1221E+00,' 
0.1234E+00, 0.1247E+00,0.1261E+00,0.1274E+00,0.1287E+Oo! 
0.1300E+00, 0.1313E+00,0.1326E+00,0.1340E+00, 0.1353E+00,' 
0 . 1366E+00 , 0 . 1379E+00 , 0 . 1392E+00 , 0 . 1406E+00 , 0 . 1419E+00 \ 
0 . 1432E+00, 0 . 1445E+00, 0 . 1458E+00 , 0 . 14 71E+00 , 0 . 1483E+00,' 
0 . 1496E+00 , 0 . 1509E+00 , 0 . 1522E+00 , 0 . 1534E+00 , 0 . 1546E+00 / 
DATA (PCGTFl (I) ,1=151,200)/ 

0.1559E+00, 0.1571E+00,0.1583E+00,0.1595E+00, 0.1607E+00, 
O.1619E+00,O.1631E+00,0.1643E+00,0.1654E+00,O.1666E+0o' 
0.1677E+00,0.1689E+00,0.1700E+00,0.1711E+00,0.1723E+00,' 
0. 1734E+00, 0.1745E+00,0.1756E+00,0.1766E+00, 0. 1777E+0o] 
0 . 1788E+00, 0 . 1799E+00 , 0 . 1809E+00, 0 . 1820E+00, 0 . 1830E+Oo! 

0.1840E+00, 0.1851E+00,0.1861E + 00,0.1871E+00, 0.1881E+00,' 
0.1891E+00, 0.1901E+00, 0.1911E+00, 0.1921E+00, 0.1930E+00,' 
0 . 1940E+00, 0 . 1950E+00 , 0 . 1959E+00 , 0 . 1969E+00, 0 . 1978E+00,' 
0.1987E+00,0.1997E+00,0.2006E+00,0.2015E+00,0.2024E+00,' 
0.2033E+00, 0.2042E+00,0.2051E+00,0.2060E+00, 0.2069E+00/ 
DATA (PCGTFl (I) ,1=201,250)/ 

0.2078E + 00, 0.2087E+00,0.2095E+00,0.2104E+00, 0.2113E+00, 
0.2121E+00, 0.2130E+00, 0.2138E+00, 0.2147E+00,0.2155E+00,' 
0.2163E+00, 0.2172E+00, 0.2180E+00, 0.2188E+00, 0.2196E+00,' 
0.2204E+00, 0.2212E+00,0.2220E-f00,0.2228E + 00,0.2236E+O0,' 
0 . 2244E+00 , 0 . 2252E+00 , 0 . 2260E+00 , 0 . 2268E+00 , 0 . 2276E+00,' 
0 . 2283E + 00, 0 . 2291E+00 , 0 . 2299E+00 , 0 . 2306E+00 , 0 . 2314E+Oo! 
0.2322E + 00, 0,2329E+00, 0.2337E+00, 0.2344E+00, 0.2352E+Oo! 
0.2359E+00, 0.2367E+00, 0.23 74E+00, 0.2381E+00, 0.2389E+Oo! 
0.2396E+00, 0.2403E+00, 0.2411E+00, 0.2418E+00, 0 .2425E+00,' 
0.2432E+00, 0.2440E+00,0.2447E+00,0.2454E+00,0.2461E+00/ 
DATA (PCGTFl (I) ,1=251,300)/ 

0.2468E+00, 0.2475E+00, 0.2483E+00, 0.2490E+00,0.2497E+00, 

0.2504E+00, 0.2511E+00, 0.2518E+00, 0.2525E+00, 0.2532E+00,' 

0.2539E+00, 0.2546E+00,0.2553E+00, 0.2560E+00,0.2567E+00,' 

0.2574E+00,0.2581E+00,0.2588E+00,0.2595E+00,0.2602E+Oo! 

0,2609E+00,0.2616E+00,0.2622E+00,0.2629E+00,0.2636E+00,' 

0.2643E+00,0.2650E+00,0.2657E+00,0.2664E+00,0.2670E+Oo! 

0.2677E+00,0.2684E+00,0.2691E+00, 0.2698E+00, 0.2704E+00,' 

0.2711E+00, 0.2718E+00,0.2725E+00, 0.2731E+00, 0.2738E+00,' 

0.2745E+00, 0.2752E+00,0.2758E+00,0.2765E+00,0.2772E+Oo' 

0.2779E+00,0.2785E+00,0.2792E+00,0.2799E+00,0.2805E+00/ 
DATA (PCGTFl (I) ,1=301,350)/ 

0.2812E+00,0.2819E+00,0.2826E+00,0.2832E+00,0.2839E+00, 
0.2846E+00,0.2852E+00,0.2859E+00,0.2866E+00,0.2872E+00,' 
0.2879E+00,0.2886E+00,0.2892E+00,0.2899E+00,0.29O6E+0o! 
0.2912E+00,0.2919E+00,0.2926E+00,0.2932E+00,0.2939E+Oo! 
0.2946E+00,0.2952E+00,0.29S9E+00,0.2966E+00,0.2972E+00,' 
0.2979E+00,0.2985E+00,0.2992E+00,0.2999E+00,0.3005E+Oo! 
0.3012E+00,0.3019E+00,0.3025E+00,0.3032E+00,0.3039E+Oo! 
0.3046E+00,0.3052E+00,0.3059E+00,0.3066E+00,0.3072E+00,' 
0.3079E+00,0.3086E+00,0.3092E+00,0.3099E+00,0.3106E+Oo! 



0.3113E + 00, CT*rL9E+00 

DATA (PCGTFl (I) , 1=351 
0.3146E+00, 0.3153E+00 
0.3180E+00, 0.3187E+00 
0.3214E+00, 0.3221E+00 
0.3248E+00, 0.3255E+00 
0.3283E+00, 0.3290E+00 
0. 3318E+00, 0.3324E+00 
0.3352E+00, 0.3360E+00 
0.3388E+00,0.3395E+00 
0.3423E+00, 0.3430E+00 
0.3459E+00, 0.3466E+00 
DATA (PCGTFl (I) , 1=401 
0.3495E-f00, 0.3502E+00 
0.3531E+00, 0.3538E+00 
0.3567E+00, 0.3574E+00 
0.3603E+00, 0 .3610E+00 
0.3639E+00, 0.3647E+00 
0.3676E+00, 0.3683E+00 
0.3712E+00, 0 .3719E+00 
0.3748E+00,0.3755E+00 
0 . 3 784E+00, 0 . 3792E+00 
0.3821E+00,0.3828E+00 
DATA (PCGTFl (I) , 1=451 
0.3857E+00, 0.3864E+00 
0.3893E+00, 0 .3900E+00 
0.3929E+00, 0.3936E+00 
0.3964E+00, 0.3 971E+00 
0.4000E+00, 0.4007E+00 
0.4035E+00, 0.4042E+00 
0.4070E+00, 0 .4077E+00 
0 .4104E+00, 0.4111E+00 
0.4139E+00, 0.4146E+00 
0.4173E+00, 0.4179E+00 
DATA (PCGTFl (I) , 1=501 
0.4206E+00, 0.4209E+00 
0.4220E+00, 0.4223E+00 
0.4234E+00, 0.4237E+00 
0.4249E+00, 0.4251E+00 
0 .4263E+00, 0.4266E+00 
0.4277E+00, 0.428 OE+00 
0.4291E+00, 0.42 94E+00 
0.4306E+00, 0.4309E+00 
0.4320E+00, 0.4323E+00 
0.4334E+00, 0.4337E+00 
DATA (PCGTFl (I) , 1=551 
0.4349E+00, 0.4352E+00 
0 .4363E+00, 0\4366E+00 
0.43 78E+00, 0.4381E+00 
0.4393E+00, 0.4396E+00 
0.4407E+00, 0.4410E+00 
0.4422E+00, 0.4425E+00 
0.4437E+00, 0.4440E+00 
0.4452E+00, 0.4455E+00 
0 .4467E+00, 0.4469E+00 
0 . 4481E+00 , 0 . 4484E+00 
DATA (PCGTFl (I) ,1=601 
0.4496E+00, 0.4499E+00 
0.4511E+00, 0,4514E+00 
0.4526E+00, 0.4530E+00 



,0.3126E+00,0 
,400)/ 

,0.3160E+00,0 
,0.3194E+00,0 
,0.3228E+00,0 
,0.3262E+00,0, 
,0.3297E+00,0, 
,0.3331E+00,0, 
,0.3367E+00,0, 
, 0.3402E+00,0. 
,0.3437E+00,0. 
,0.3473E+00,0. 
,450)/ 

, 0.3509E+00, 0. 
,0.3545E+00,0. 
,0.3581E+00,0. 
,0.3618E+00,0, 
,0.3654E+00,0. 
,0.3690E+00,0. 
, 0.3726E+00, 0. 
,0.3763E+00,0, 
,0.3799E+00,0. 
,0.3835E+00,0. 
,500)/ 

, 0.3871E+00, 0. 
,0.3907E+00,0. 
,0.3943E+00,0. 
, 0.3978E+00, 0. 
,0.4014E+00,0. 
, 0.4049E+00, 0. 
, 0.4084E+00, 0. 
,0.4118E+00,0. 
,0.4152E+00,0. 
, 0.4186E+00, 0. 
,550)/ 

,0.4212E+00,0. 
, 0.4226E+00, 0. 
, 0.4240E+00, 0. 
,0,4254E+00,0. 
,0.4268E+00,0. 
, 0.4283E+00, 0. 
,0.4297E+00,0. 
,0.4311E+00,0. 
, 0.4326E+00, 0. 
, 0.4340E+00, 0. 
,600)/ 

,0.4355E+00,0. 
,0.4369E+00,0. 
, 0.4384E+00, 0. 
,0.4399E+00,0. 
,0.4413E+00,0. 
, 0.4428E+00, 0. 
, 0.4443E+00, 0. 
, 0.4458E+00, 0. 
, 0.4472E+00, 0. 
,0.4487E+00,0. 
,650)/ 

, 0.4502E+00, 0. 
, 0.4517E+00, 0. 
,0.4533E+00,0. 



dT?13! 



3133E+00, 0T7l39E+00/ 



3167E+00, 0. 
3200E+00,0. 
3235E+00, 0. 
3269E+00, 0. 
3304E+00,0. 
3338E+00, 0. 
3374E+00, 0. 
3409E+00, 0. 
3445E+00, 0. 
3480E+00, 0. 

3516E+00, 0. 
3552E+00,0. 
3589E+00,0. 
3625E+00, 0. 
3661E+00, 0. 
3697E+00,0. 
3734E+00, 0. 
3770E+00, 0. 
3806E+00, 0. 
3842E+00, 0. 



3173E+00, 
3207E+00, 
3241E+00, 
3276E+00, 
3311E+00, 
3345E+00, 
3381E+00, 
3416E+00, 
3452E+00, 
3488E+00/ 

3524E+00, 
3560E+00, 
3596E+00, 
3632E+00, 
3668E+00, 
3705E+00, 
3741E+00, 
3777E+00, 
3813E+00, 
3850E+00/ 



3878E+00, 0 
3914E+00, 0 
3950E+00, 0 
3985E+00, 0 
4021E+00, 0 
4056E+00, 0 
4091E+00, 0 
4125E+00, 0 
4159E+00, 0 
4193E+00,0 

4215E+00, 0 
4229E+00,0, 
4243E+00, 0, 
4257E+00, 0. 
4271E+00, 0. 
4286E+00, 0. 
4300E+00, 0. 
4314E+00, 0. 
4329E+00, 0. 
4343E+00, 0. 

4358E+00, 0. 
4372E+00, 0. 
4387E+00, 0. 
4401E+00, 0. 
4416E+00,0. 
4431E+00,0. 
4446E+00, 0. 
4461E+00,0. 
4475E+00, 0. 
4490E+00, 0. 



.3886E+00, 
.3921E+00, 
.3957E+00, 
.3993E+00, 
.4028E+00, 
.4063E+00, 
.4097E+00, 
.4132E+00, 
.4166E+00, 
.4200E+00/ 

.4218E+00, 
.4232E+00, 
.4246E+00, 
.4260E+00, 
.4274E+00, 
.4288E+00, 
.4303E+00, 
.4317E+00, 
.4332E+00, 
.4346E+00/ 

,4361E+00, 
,4375E+00, 
,4390E+00, 
4404E+00, 
4419E+00, 
4434E+00, 
4449E+00, 
4464E+00, 
4478E+00, 
4493E+00/ 



4505E+00, 0.4508E+00, 
4520E+00, 0.4523E+00, 
4536E+00, 0.4539E+00, 



0 . 4542E+^fcf 4545E+00, 0 . 4548E+00 , 0 . 4551E+^^. 4554E+00 , 
0 . 4557E+00, 0 . 4560E+00, 0 . 4563E+00, 0 . 4566E+00, 0 . 4569E+Oo' 
0 . 4572E+00, 0 . 4575E+00, 0 .4578E+00, 0 . 4581E+00, 0 . 4584E+0o' 
0.4587E+00,0.4590E+00,0.4593E+00.0.4596E+00,0.4600E+00,' 
0 . 4603E+00, 0.4606E+00, 0.4609E+00, 0.4612E+00, 0. 4615E+0o! 
0 .4618E+00, 0.4621E+00, 0.4624E+00. 0.4627E+00, 0. 4630E+00,' 

0.4633E+00,0.4636E+00,0.4640E+00.0.4643E+00,0.4646E+00/ 
DATA (PCGTFl (I) ,1=651,700)/ 

0.4649E+00,0.4652E+00,0.4655E+00,0.4658E+00,0.4661E+00, 

0.4664E+00,0.4668E+00,0.4671E+00,0.4674E+00,0.4677E+00,' 

0.4680E+00,0.4683E+00,0.4686E+00,0.4689E+00,0.4692E+00,' 

0.4696E+00, 0.4699E+00,0.4702E+00,0.4705E+00,0.4708E+00,' 

0.4711E+00, 0.4714E+00,0.4718E+00,0.4721E+00,0.4724E+00, 

0.4727E+00,0.4730E+00,0.4733E+00,0.4736E+00,0.4740E+00,' 

0.4743E+00, 0.4746E+00,0.4749E+00,0.4752E+00,0.4755E+Oo! 

0.4759E+00, 0.4762E+00.0.4765E+00,0.4768E+00,0.4771E+00, 

0.4775E+00, 0.4778E+00,0.4781E+00,0.4784E+00,0.4787E+Oo! 

0.4791E+00, 0.4794E+00,0.4797E+00,0.4800E+00,0.4803E+00/ 
DATA (PCGTFl (I) , 1 = 701, 750) / 

0.4807E+00,0.4810E+00,0.4813E+00,0.4816E+00,0.4819E+00, 

0.4823E+00, 0.4826E+00,0.4829E+00,0.4832E+00, 0.4835E+00,' 

0.4839E+00,0.4842E+00,0.4845E+00,0.4848E+00,0.4852E+00,' 

0.4855E+00,0.48S8E+00,0.4861E+00,0.4865E+00,0.4868E+Oo! 

0.4871E+00,0.4874E+00,0.4878E+00,0.4881E+00,0.4884E+Oo! 

0.4887E+00,0.4891E+00,0.4894E+00,0.4897E+00,0.4900E+00,' 

0.4904E+00,0.4907E+00,0.4910E+00,0.4913E+00,0.4917E+00,' 

0.4920E+00,0.4923E+00,0.4927E+00,0.4930E+00,0.4933E+00,' 

0.4936E+00,0.4940E+00,0.4943E+00,0.4946E+00,0.4950E+Ooi 

0.4953E+00,0.49S6E+00,0.4960E+00,0.4963E+00,0.4966E+00/ 
DATA (PCGTFl (I) ,1=751,800)/ 

0.4969E+00,0.4973E+00,0.4976E+00,0.4979E+00,0.4983E+00, 
0.4986E+00,0.4989E+00,0.4993E+00,0.4996E+00,0.4999E+00,' 
0.5003E+00,0.5006E+00,0.5009E+00,0.5013E+00,0.5016E+Oo' 
0.5019E+00,0.5023E+00,0.5026E+00,0.5030E+00,O.S033E+00,' 
0 . 5036E+00, 0. 5040E+00, 0 . 5043E+00, 0 . 5046E+00, 0 . 5050E+00,' 

0.5053E+00,0.5056E+00,0.5060E+00,0.5063E+00,0.5067E+Oo' 
0.5070E+00,0.5073E+00,0.5077E+00,0.5080E+00,O.S083E+Oo' 
0 . 5087E+00 , 0 . 5090E+00 , 0 . 5094E+00 , 0 . 5097E+00, 0 . 5100E+00 ' 
0 . 5104E+00, 0 . 5107E+00, 0 . 5111E+00 , 0 . 5114E+00, 0 . 5117E+Oo' 
0 . 5121E+00 , 0 . 5124E+00 , 0 . 5128E+00 , 0 . 5131E+00 , 0 . 5135E+00/ 
DATA (PCGTFl (I) ,1=801,850)/ 

0 . 5138E+00, 0 . 5141E+00 , 0 . 5145E+00 , 0 . 5148E+00, 0 . 5152E+00 

0.5155E+00,0.5159E+00,0.5162E+00,0.5165E+00,0.5169E+00,' 

0.5172E+00,0.5176E+00,0.5179E+00,0.5183E+00,0.5186E+00' 

0.5190E+00,0.5193E+00,0.5197E+00,0.5200E+00,0.5204E+Oo' 

0.5207E+00,0.5210E+00,0.5214E+00,0.5217E+00,0.5221E+00' 

0 . 5224E+00. 0 . 5228E+00 , 0 . 5231E+00 , 0 . S235E+00, 0 . 5238E+Oo' 

0.5242E+00.0.5245E+00,0.5249E+00,O.S252E+00,0.5256E+00' 
0.5259E+00.0.5263E+00,0.5266E+00,0.5270E+00,0.5273E+00' 
0.5277E+00,0.5280E+00,0.5284E+00,0.5287E+00.0.5291E+00' 
0.5295E+00,0.5298E+00,0.5302E+00,0.5305E+00,0 5309E+00/ 
DATA (PCGTFl (I) ,1=851,900)/ 

0 . 5312E+00, 0 . 5316E+00, 0 . 5319E+00, 0 . 5323E+00, 0 . 5326E+00 
0 . 5330E+00, 0 . 5334E+00 , 0 . 5337E+00 , 0 . 5341E+00, 0 . 5344E+00 ' 
0 . 5348E+00, 0 . 5351E+00 , 0 . 5355E+00 , 0 . 5358E+00. 0 . 5362E+00 ' 
0 . 5366E+00, 0 . 5369E+00 , 0 . 5373E+00 , 0 . 5376E+00 , 0 . 5380E+00 ' 
0 . 5384E+00, 0 . 5387E+00, 0 . 5391E+00, 0 . 5394E+00, 0 . 5398E+00 ' 

0.5402E+00,0.5405E+00,0.5409E+00,O.S412E+00,0.5416E+00' 
0 . 5420E+00, 0 . 5423E+00 , 0 . 5427E+00, 0 . 5430E+00, 0 . 5434E+00 ' 
0 . 5438E+00. 0 . 5441E+00, 0 . 5445E+00, 0 . 5449E+00, 0 . 5452E+00,' 
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0.5456E+00, 0^Wl9E+00, 0.5463E+00, 0.5467E+00,0.5470E+00, 
0 . 5474E+00, 0 . 5478E+00 , 0 . 5481E+00 , 0 . 5485E+00, 0 . 5489E+00/ 
DATA {PCGTFl (I) , 1=901, 950) / 

0 . 5492E+00 , 0 . 5496E+00 , 0 . 5500E+00 , 0 . 5503E+00 , 0 . 5507E + 00 , 
0 . 5511E+00 , 0 . 5514E+00 , 0 . 5518E+00 , 0 . 5522E+00 , 0 . 5525E + 00 , 
0.552 9E+00,0.5533E+00,0.5536E+00,0.5540E+00,0.5544E+00, 
0.5548E+00, 0.5551E+00,0.5555E+00,0.5559E+00, 0.5562E+00, 
0.5566E+00,0.5570E+00, 0.5574E+00,0.5577E+00,0.5581E+00, 
0.558 5E+00, 0.5588E+00,0.5592E+00,0. 5596E+00, 0.5600E+00, 
0.5603E+00, 0.5607E+00, 0.5611E+00,0.5615E+00, 0.5618E+00, 
0 . 5622E+00, 0 . 5626E+00 , 0 . 5630E+00 , 0 . 5633E+00 , 0 . 563 7E+00, 
0 . 5641E+00, 0 . 5645E+00 , 0 . 564 8E+00 , 0 . 5652E+00, 0 . 5656E+00, 
0 . 5660E+00, 0 . 5663E+00, 0. 5667E+00, 0 . 5671E+00, 0 . 5675E+00/ 
DATA (PCGTFl (1) , 1 = 951, Nrigs) / 

0. 5679E+00, 0 . 5682E+00 , 0 . 5686E+00 , 0 . 5690E+00, 0 . 5694E+00, 
0.5698E+00,0. 5701E+00, 0.5705E+00,0.5709E+00, 0.5713E+00, 
0.5717E+00, 0. 572 0E+00, 0.5724E+00, 0.5728E+00, 0.5732E+00, 
0.5736E+00, 0. 5740E+00, 0.5743E+00,0.5747E+00, 0.5751E+00, 
0.5755E+00,0.5759E+00,0.5763E+00,0.5766E+00, 0.5770E+00, 
0.5774E+00, 0.5778E+00, 0.5782E+00, 0.5786E+00, 0. 5789E+00, 
0.5793E+00,0.5797E+00,0.5801E+00,0.5805E+00, 0.58 09E+00, 
0 . 5813E+00 , 0 . 5817E+00 , 0 . 582aE + 00 , 0 . 5824E+00, 0 . 582 8E+00 , 
0.5832E+00,0.5836E+00,0.584 0E+00,0.5844E+00, 0.5848E+00, 
0 . 5852E+00 , 0 . 5856E+00 , 0 . 5859E+00 , 0 . 5863E+00 , 0 . 586 7E+00, 
0.5871E+00/ 

DATA (PCGTF2 (1) ,1=1, 50) / 

0.4848E-01, 0.4962E-01, 0.5075E-01, 0.5189E-01, 0.53 03E-01, 
0.5417E-01, 0.5533E-01, 0.5646E-01, 0.5754E-01, 0!5861E-01, 
0.5976E-01, 0.6109E-01, 0.6272E-01, 0.6472E-01, 0.6689E-01, 
0.6874E-01, 0.6 991E-01, 0.706 7E-01, 0.7145E-01, 0.7242E-01, 
0.7351E-01, 0.7463E-01, 0.7570E-01, 0.7664E-01, 0.7742E-01, 
0.7809E-01, 0.7869E-01, 0.7927E-01, 0.7987E-01, 0.8050E-01, 
0.8118E-01, 0. 8190E-01, 0.8265E-01, 0.8343E-01, 0 .8425E-01, 
0.8510E-01, 0. 8597E-01, 0.8687E-01, 0.8779E-01, 0.88 73E-01, 
0.8970E-01, 0. 9068E-01, 0.9168E-01, 0.9269E-01, 0.9371E-01, 
0.9474E-01, 0. 9578E-01, 0.9682E-01, 0.9787E-01, 0.9892E-01/ 
DATA (PCGTF2 (1) ,1=51, 100) / 

0.9997E-01, 0. lOlOE+00, 0.1021E + 00, 0.1031E+00, 0.1041E+00, 
0.1051E+00, 0.1062E+00, 0.1072E+00, 0.1082E+00, 0. 1092E+00, 
0.1102E+00, 0. llllE+00, 0.1121E+00, 0.1131E+00, 0.1141E+00, 
0.1151E+00, 0.1160E+00, 0.1170E+00, 0.1179E+00, 0.1189E+00, 
0.1199E+00, 0. 1208E+00, 0.1218E+00, 0.1227E+00, 0.1237E+00, 
0 . 1246E+00 , 0 . 1256E+00 , 0 . 1266E+00 , 0 . 1275E+00 , 0 . 1285E+00 , 

0.1294E+00, 0.1304E+00, 0.1313E+00, 0.1323E+00, 0.1333E+00, 
0 . 1343E+00 , 0 . 1352E+00 , 0 . 1362E+00 , 0 . 1372E+00 , 0 . 1382E + 00 , 
0.1392E+00,0. 1402E+00, 0.1412E+00, 0.1422E+00, 0.1432E+00, 
0 . 1442E+00 , 0 . 1453E+00 , 0 . 1463E+00 , 0 . 1474E+00 , 0 . 1484E+00 / 
DATA (PCGTF2 (I) ,1=101,150)/ 

0.1495E+00, 0.1505E+00, 0.1516E+00, 0.1527E+00, 0.1538E + 00, 
0.1549E+00, 0. 1560E+00, 0.1571E + 00, 0.1582E+00, 0.1593E+00, 
0.1604E+00, 0.1616E+00, 0.1627E+00, 0.1638E+00, 0. 1650E+00, 
0.1661E+00, 0. 1672E+00, 0. 1684E + 00, 0. 1695E+00, 0. 1707E+00, 
0 . 1718E+00, 0 . 1729E+00, 0 . 1741E+00, 0 . 1752E+00, 0 . 1764E + 00 [ 
0 . 1775E+00, 0 . 1787E+00 , 0 . 1798E+00 , 0 . 1810E+00 , 0 , 1821E+00 , 
0.1832E+00,0.1844E+00, 0.1855E+00,0.1866E+00,0.1878E+00, 
0.1889E+00, 0. 1900E+00, 0. 1911E+00, 0. 1922E+00, 0. 1933E+00, 
0.1944E+00,0.1955E+00,0.1966E+00,0.1977E+00,0.1988E+00,' 
0.1998E+00, 0.2009E+00,0.2020E+00, 0.2030E+00, 0.2040E + 00/ 
DATA (PCGTF2 (I) ,1=151,200)/ 

0.2051E+00, 0.2061E+00, 0.2071E+00, 0.2081E+00, 0.2091E+00, . 



0 . 2101E+OO^P2111E+00 
0 . 2149E+00 , 0 . 2159E+00 
0. 2l96E+00,0.2205E+00 
0 . 2241E+00, 0 . 2250E+00 
0 . 2284E+00 , 0 . 22 93E+00 
0.2326E+00,0.2334E+00 
0 . 2367E+00, 0 . 23 75E+00 
0 . 2406E+00 , 0 . 2414E+00 
0.2444E+00, 0 .24 51E+00 
DATA (PCGTF2 (I) , 1=201 
0 . 2481E+00 , 0 . 24 88E+00 
0.2517E+00, 0.2524E+00 
0 . 2551E+00, 0 . 2558E+00 
0.2586E+00, 0.2592E+00 
0 .2619E+00, 0 .2626E+00 
0 . 2652E+00 , 0 . 26 58E+00 
0.2684E+00, 0.26 90E+00 
0 .2716E+00, 0 .2722E+00 
0.2747E+00, 0.2753E+00, 
0,2778E+00, 0.2785E+00, 
DATA (PCGTF2 (I) , 1=251, 
0.2810E+00, 0.2816E+00. 
0.2840E+00, 0.2847E+00. 
0.2871E+00, 0.2878E+00, 
0.2902E+00, 0.2908E+00. 
0.2933E+00, 0.2939E+00. 
0.2964E+00, 0.2970E+00, 
0.2994E+00, 0.3000E+00, 
0.3024E+00, 0.3030E+00. 
0.3054E+00, 0.3060E+00. 
0.3084E+00, 0.3090E+00, 
DATA {PCGTF2 (I) , 1=301, 
0.3114E+00, 0.3120E+00, 
0 . 3144E+00, 0 . 3150E+00 , 
0,3173E+00, 0\3179E+00, 
0 . 3202E+00 , 0 . 3208E+00, 
0.3231E+00, 0.3236E+00, 
0.3259E+00,0.3265E+00, 
0.3287E+00, 0.3293E+00, 
0.3315E+00, 0.3321E+00, 
0. 3343E+00, 0.3348E+00, 
0.3370E+00,0.3375E+00, 
DATA (PCGTF2 (I) , 1=351, 
0 . 3396E+00, 0 . 3402E+00 , 
0 . 3423E+00 , 0 . 3428E+00 , 
0. 3449E+00, 0 .3454E+00, 
0 . 3474E+00, 0 . 3479E+00, 
0.3499E+00, 0.3504E+00, 
0 . 3524E+00, 0 . 352 9E+00, 
0 . 3548E+00 , 0 . 3553E+00 , 
0 .3572E+00, 0.3576E+00, 
0 . 3595E+00, 0 . 3599E+00, 
0 . 3618E+00 , 0 . 3622E+00 , 
DATA (PCGTF2 (I) ,1=401, 
0 . 3640E+00 , 0 . 3645E+00 , 
0 . 3662E+00, 0 . 3667E+00 , 
0.3684E+00, 0.3689E+00, 
0 . 3706E+00, 0 . 3710E+00, 
0.3727E+00, 0.3731E+00, 
0.3748E+00, 0.3752E+00, 



, 0 . 2121E+00 , 0 . 2130E+00, 0 . 2140E+00, 
, 0.2168E+00, 0.2178E+00, 0.2187E+00, 
, 0.2214E+00, 0 .2223E+00, 0.2232E+00, 
,0.2258E+00, 0 . 2267E+00 , 0 . 2276E+00 , 
, 0.2301E+00, 0.2310E+00, 0.2318E+00, 
, 0.2343E+00, 0 .23 51E+00, 0 . 2359E+00, 
, 0 .2382E+00, 0 .23 90E+00, 0 .2398E+00, 
, 0 . 2421E+00 , 0 . 242 9E+00 , 0 . 2436E+00, 
, 0.2459E+00, 0 .2466E+00, 0 . 2473E+00/ 
,250)/ 

. 0 .24 95E+00, 0 . 2502E+00, 0 . 2S09E+00, 
, 0.253 lE+00, 0.2538E+00, 0,2545E+00, 
, 0.256 5E+00, 0.2 572E+00, 0.2579E+00, 
, 0.2599E+00, 0 .2606E+00, 0 . 2612E+00, 
, 0.2632E+00, 0 .2639E+00, 0 .264 5E+00, 
, 0.2665E+00, 0 . 2671E+00, 0 . 2678E+00, 
, 0.26 97E+00, 0 .2703E+00, 0 .2709E+00, 
0.2728E+00, 0.2735E+00, 0.2741E+00, 
0.2760E+00, 0 .2766E+00, 0 . 2 772E+00, 
0.2791E+00, 0.2797E+00, 0 .2803E+00/ 
300)/ 

0.2822E+00, 0.2828E+00, 0.2834E+00, 
0.2853E+00, 0.28 59E+00, 0.2865E+00, 
0.2884E+00, 0.28 90E+00, 0.2896E+00, 
0.2 915E+00, 0 .2921E+00, 0 ,292 7E+00, 
0.2945E+00, 0.2951E+00, 0.2957E+00, 
0.2 976E+00, 0.2 982E+00, 0.2988E+00, 
0.3 006E+00, 0.3012E+00, 0.3 018E+00, 
0.3036E+00, 0.3 042E+00, 0.3048E+00, 
0.3066E+00, 0.3072E+00, 0.3t)78E+00, 
0.3 096E+00, 0.3102E+00, 0.3108E+00/ 
350)/ 

0.3126E+00, 0.3132E+00, 0. 3138E+00, 
0.3155E+00, 0 .3161E+00, 0 . 3167E+00, 
0.31ff5E+00, 0.3190E+00, 0.3196E+00, 
0.3213E+00, 0.3219E+00, 0.3225E+00, 
0.3242E+00, 0.3248E+00, 0.32 53E+00, 
0.3270E+00, 0.3276E+00, 0.32 82E+00, 
0.32 98E+00, 0.33 04E+00, 0. 3310E+00, 
0.3326E+00, 0.3332E+00, 0.333 7E+00, 
0.3353E+00, 0.3359E+00, 0.3364E+00, 
0.3380E+00, 0.3386E+00, 0.33 91E+00/ 
400) / 

0.34 07E+00, 0.3412E+00, 0 .3417E+00, 
0.343 3E+00, 0.3438E+00, 0.3444E+00, 
0. 34 59E+00, 0 .3464E+00, 0 .3469E+00, 
0 . 3484E+00 , 0 . 3489E+00, 0 . 34 94E+00 , 
0.3509E+00, 0.3514E+00, 0.3 519E+00, 
0.3534E+00, 0 .3538E+00, 0.3 543E+00, 
0.3557E+00, 0.3 562E+00, 0 .3567E+00, 
0.3581E+00, 0. 3586E+00, 0 . 3 590E+00, 
0.3604E+00, 0.3609E+00, 0.3613E+00, 
0.3627E+00, 0 . 3631E+00, 0 . 3636E+00/ 
450)/ 

0.364 9E+00, 0.3654E+00, 0.3658E+00, 
0.3671E+00, 0.36 76E+00, 0 .3680E+00, 
0.36 93E+00, 0.3697E+00, 0.3 702E+00, 
0.3714E+00, 0.3719E+00, 0.3723E+00, 
0.3736E+00, 0.374 OE+00, 0.3744E+00, 
0.3757E+00, 0.3761E+00, 0 .376 5E+00, 



. 3782E+00 , 0 . 3786E+00 , 
. 3802E+00, 0. 3807E+00, 
. 3823E+00, 0 . 3827E+00, 
. 3844E+00, 0.3848E+00/ 



0 . 3769E+00, (^^73E+00, 0 . 3778E+00, 0 
0 . 3790E+00 , 0 . 3794E+00 , 0 . 3798E+00, 0 
0 .3811E+00, 0. 3815E+00, 0. 3819E+00, 0 
0 . 3831E+00 , 0 . 3835E+00, 0 . 3839E+00, 0 
DATA (PCGTF2 (I) , 1=451,500)/ 

0 . 3852E+00, 0 . 3856E+00 , 0 . 3860E+00 , 0 . 3864E+00, 0 
0 . 3872E+00, 0 . 3 876E+00, 0 . 3880E+00 , 0 . 3884E+00, 0 
0 . 38 93E+00 , 0 . 3897E+00, 0 . 3 901E+00, 0 . 3 905E+00, 0 
0 . 3913E+00, 0 . 3 917E+00, 0 . 3 921E+00, 0 . 3 92 5E+00, 0 
0 . 3934E+00, 0 . 3 938E+00, 0 . 3 942E+00, 0 . 3 946E+00, 0 
0 . 3954E+00, 0 . 3 958E+00, 0 . 3 963E+00 , 0 . 3 967E+00, 0 
0 . 3975E+00, 0 . 3 979E+00, 0 . 3 983E+00, 0 . 3 987E+00, 0 
0.3996E+00, 0.4000E+00,0.4004E+00, 0.4008E+00, 0 
0 .4017E + 00, 0.4 021E+00, 0.4025E+00, 0 . 4 03 0E+00, 0 
0 .4038E+00, 0 . 4042E+00, 0 .404 7E+00, 0 . 4051E+00, 0 
DATA (PCGTF2 (I) ,1=501,550)/ 

0 .4060E+00, 0 .4063E+00, 0.4 066E+00, 0 .406 9E+00, 0 
0 . 4075E+00, 0 . 4078E+00, 0 . 4081E+00, 0 . 4084E+00, 0 
0 .4 090E+00, 0 . 4093E+00, 0 . 4 096E+00, 0 . 4100E+00, 0 
0.4106E+00, 0.4109E+00, 0.4112E + 00, 0.4115E+00, 0 
0 .4121E+00, 0 .4124E+00, 0.4127E+00, 0 . 4131E+00, 0 
0.413 7E+00, 0.4140E+00,0.4143E + 00, 0.4146E+00, 0 
0 .4152E + 00, 0 .4156E+00, 0.4159E+00, 0.4162E+00, 0 
0.4168E + 00, 0.4171E+00, 0.4174E+00, 0.4178E+00, 0 
0 .4184E+00, 0 .4187E+00, 0 .4190E+00, 0 . 4193E+00, 0 
0 .4200E+00, 0 .4203E+00, 0 .42 06E+00, 0 .42 09E+00, 0 
DATA {PCGTF2 (I) ,1=551,600)/ 

0.4216E+00, 0 .4219E+00, 0.4222E+00, 0.4225E+00, 0 
0.4231E+00, 0.4235E+00, 0.4238E+00, 0.4241E+00, 0 
0 .4247E+00, 0 .4251E+00, 0.4254E+00, 0.4257E+00, 0 
0 .4264E + 00, 0.426 7E+00, 0 .4270E + 00, 0.42 73E+00, 0, 
0 .4280E+00, 0 .4283E+00, 0 .4286E+00, 0 .4289E+00, 0 , 
0. 4296E+00, 0.42 99E+00, 0 .4302E+00, 0 .43 06E+00, 0 , 
4312E+00, 0 .4315E+00, 0.4319E+00, 0. 4322E+00, 0 . 
4328E+00, 0 .4332E+00, 0 .433 5E+00, 0.4338E+00, 0, 
4345E+00, 0.4348E + 00, 0.43 51E+00, 0.4 3 55E + 00, 0. 
4361E + 00, 0 .4364E+00, 0 .4368E+00, 0.43 71E+00, 0 . 
DATA {PCGTF2 (I) ,1=601,650)/ 

0.4378E + 00, 0.4381E+00, 0 .4384E+00, 0.4 388E+00, 0. 
4394E+00, 0 .43 97E+00, 0 .4401E+00, 0.44 04E+00, 0. 
4411E+00, 0.4414E+00, 0.4417E+00, 0.4421E+00, 0 . 
4427E+00, 0.4431E+00, 0.4434E+00, 0.443 7E+00, 0. 
4444E+00, 0 .4447E+00, 0 .4451E+00, 0 . 44 54E+00, 0 . 
4461E+00, 0 .4464E+00, 0 . 4468E+00 , 0 . 4471E+00 , 0. 
4478E+00, 0 .4481E+00, 0 .4485E+00, 0 .4488E+00, 0. 
44 95E+00, 0.44 98E+00, 0.4502E+00, 0.4 505E+00, 0. 
4512E+00, 0.4 515E + 00, 0.4519E+00, 0.4522E+00, 0. 
4 529E+00, 0.4532E+00, 0.4536E+00, 0.453 9E+00, 0. 
DATA (PCGTF2 (I) , 1=651, 700) / 

0.4546E+00, 0 .4549E+00, 0 .4553E+00, 0 .4556E+00, 0. 
0.4563E+00, 0.4566E+00, 0.4570E+00, 0 .4573E+00, 0. 
0 .4580E+00, 0 .4584E+00, 0 .4587E+00, 0 .4591E+00, 0. 
0. 4598E+00, 0.4601E+00, 0.4605E+00, 0 .4608E+00, 0. 
0.4615E+00, 0.4618E+00, 0.4622E+00, 0 .4625E+00, 0. 
0.4632E+00, 0.4636E+00, 0 .463 9E+00, 0 . 4643E+00 , 0 . 
0.4650E+00, 0.4653E+00, 0.4657E+00, 0.4660E+00, 0. 
0 .4667E+00, 0 .4671E+00, 0 .4675E+00, 0 .4678E+00, 0. 
0 . 4685E+00, 0 . 4689E+00 , 0 . 4692E+00 , 0 . 4696E+00 , 0 . 
0.4 703E+00, 0.4706E+00, 0.4 710E+00, 0.4713E+00, 0 




0. 
0. 
0. 
0. 



.3868E+00, 
.3889E+00, 
.3909E+00, 
.3930E+00, 
.3950E+00, 
. 3971E+00, 
.3992E+00, 
.4013E+00, 
.4034E+00, 
.4055E+00/ 

.4072E+00, 
.4087E+00, 
.4103E+00, 
.4118E+00, 
.4134E+00, 
.4149E+00, 
.4165E+00, 
.4181E+00, 
.4197E+00, 
.4212E+00/ 

.4228E+00, 
.4244E+00, 
.4260E+00, 
.4276E+00, 
.4293E+00, 
.4309E+00, 
.4325E+00, 
.4341E+00, 
.4358E+00, 
.4374E+00/ 

.4391E+00, 
,4407E+00, 
,4424E+00, 
4441E+00, 
4458E+00, 
4474E+00, 
4491E+00, 
4508E+00, 
4525E+00, 
4542E+00/ 

4560E+00, 
4577E+00, 
4594E+00, 
4611E+00, 
4629E+00, 
4646E+00, 
4664E+00, 
4682E+00, 
4699E+00, 
4717E+00/ 



DATA (PCGTF2 (I) ,1=701,750)/ 



# 0.4721E+00, 

# 0.4738E+00, 0,4742E+00 

# 0.4 756E+00, 0.4760E+00 

# 0.4774E+00, 0.4778E+00 

# 0.4792E+00, 0.4796E+00 

# 0.4810E+00, 0.4814E+00 

# 0.482 9E+00, 0.4832E+00 

# 0.484 7E+00, 0.4851E+00 

# 0 .4865E+00, 0 .486 9E+00 

# 0.4884E+00, 0.488 7E+00 
DATA (PCGTF2 (I) , 1=751 

# 0 . 4902E+00 , 0 . 4 906E+00 

# 0.4 921E+00, 0.4924E+00 

# 0.4939E+00, 0.4943E+00 

# 0.4958E+00, 0 .4962E+00 

# 0.4977E+00, 0.4980E+00 

# 0.4995E+00, 0.4999E+00 

# 0*5014E+00, 0.5018E+00 

# 0.5033E+00, 0 . 503 7E+00 

# 0.5052E+00, 0.5056E+00 

# 0 . 5071E+00 , 0 . 5075E+00 
DATA (PCGTF2 (I) , 1=801 

# 0.5091E+00, 0.5094E+00 

# 0.5110E+00, 0.5114E+00 

# 0 . 512 9E+00 , 0 . 5133E+00 

# 0.5148E+00; 0.5152E+00 

# 0 . 5168E+00, 0 . 5172E+00 

# 0.5187E+00, 0 . 5191E+00 

# 0.5207E+00, 0.5211E+00 

# 0.522 7E+00, 0.5231E+00 

# 0.5246E+00, 0.5250E+00 

# 0.5266E+00, 0.5270E+00 
DATA (PCGTF2 (I) , 1=851 

# 0.5286E+00, 0 .5290E+00 

# 0.5306E+00, 0.5310E+00 

# 0.5326E+00, 0.533 0E+00 

# 0.5346E+00, 0.5350E+00 

# 0.5367E+00, 0.5371E+00 

# 0.5387E+00, 0.5391E+00 

# 0.5407E+00, 0.5411E+00 

# 0.5428E+00, 0.5432E+00 

# 0.5448E+00, 0.5452E+00 

# 0.5469E+00, 0.5473E+00 
DATA (PCGTF2 (I) , 1=901 

# 0 . 5489E+00 , 0 . 5494E+00 

# 0.5510E+00, 0.5514E+00 

# 0 . 5531E+00, 0 . 5535E+00 

# 0.5552E+00, 0. 5556E+00 

# 0 . 5573E+00 , 0 . 5577E+00 

# 0.5594E+00, 0.5598E+00 

# 0. 5615E+00, 0. 5619E+00 

# 0 . 5636E+00 , 0 . 5641E+00 

# 0.5658E+00, 0.5662E+00 

# 0.5679E+00, 0.5683E+00 
DATA (PCGTF2 (I) , 1=951 

# 0 . 5700E+00 , 0 . 5705E+00 

# 0.5722E+00, 0. 5726E+00 

# 0.5744E+00, 0. 5748E+00 

# 0 . 5765E+00 , 0 . 5770E+00 

# 0 . 5787E+00 , 0 . 5791E+00 
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850) / 
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5184E+00, 


0. 


5195E+00, 
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5199E+00, 
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5203E+00, 


0. 


5215E+00, 


0 


5219E+00, 


0 


5223E+00, 


0. 


5235E+00, 


0 


5239E+00, 


0 


5243E+00, 


0. 


5254E+00, 


0 


5258E+00, 


0 


5262E+00, 


0. 


5274E+00, 


0 


5278E+00, 


0 


5282E+00/ 


900) / 










0. 


5294E+00, 


0, 


5298E+00, 


0 


5302E+00, 


0. 


5314E+00, 


0. 


5318E+00, 


0 


5322E+00, 


0. 


5334E+00, 


0. 


5338E+00, 


0 


5342E+00, 


0. 


5354E+00, 


0. 


5358E+00, 


0, 


5363E+00, 


0. 


5375E+00, 


0. 


5379E+00, 


0. 


5383E+00, 


0. 


5395E+00, 


0. 


5399E+00, 


0. 


5403E+00, 


0. 


5415E+00, 


0. 


5419E+00, 


0. 


5424E+00, 


0. 


5436E+00, 


0. 


5440E+00, 


0. 


5444E+00, 


0. 


5456E+00, 


0. 


5460E+00, 


0. 


5465E+00, 


0. 


5477E+00, 


0. 


5481E+00, 


0. 


5485E+00/ 


950)/ 










0. 


5498E+00, 


0. 


5502E+00, 


0. 


5506E+00, 


0. 


5518E+00, 


0. 


5523E+00, 


0. 


5527E+00, 


0. 


5539E+00, 


0. 


5543E+00, 


0. 


5548E+00, 


0. 


5560E+00, 


0. 


5564E+00, 


0. 


5569E+00, 


0. 


5581E+00, 


0. 


5585E+00, 


0. 


5590E+00, 


0. 


5602E+00, 


0. 


5607E+00, 


0. 


5611E+00, 


0. 


5624E+00, 


0. 


5628E+00, 


0. 


5632E+00, 


0. 


5645E+00, 


0. 


5649E+00, 


0. 


5653E+00, 


0. 


5666E+00, 


0. 


5670E+00, 


0. 


5675E+00, 


0. 


5688E+00, 


0. 


5692E+00, 


0. 


5696E+00/ 


Nrigs) / 










0. 


5709E+00, 


0. 


5713E+00, 


0. 


5718E+00, 


0. 


5731E+00, 


0. 


5735E+00, 


0. 


5739E+00, 


0. 


5752E+00, 


0. 


5757E+00, 


0. 


5761E+00, 


0. 


5774E+00, 


0. 


5778E+00, 


0. 


5783E+00, 


0. 


5796E+00, 


0. 


5800E+00, 


0. 


5805E+00, 



0. 5809E+00,1^813E+00, 0. 5818E+00, 0 . 5822E+00 i^^826E+00 , 

0 . 5831E+00, 0 . 5835E+00, 0 . 5840E+00, 0 . 5844E+00, 0 . 5849E+00, 
0 . 5853E+00, 0 . 58 57E+00, 0 . 5862E+00, 0 . 5866E+00, 0 . 5871E+00, 
0 . 5875E+00 , 0 . 5879E+00, 0 . 5884E+00 , 0 . 5888E+00 , 0 . 5893E+00 , 
0 . 5897E+00, 0 . 5902E+00, 0 . 5906E+00, 0 . 5911E+00, 0 . 5915E+00, 
0.5920E+00/ 

DATA (PCGTF3 (I) , 1=1, 50) / 

0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 
O.OOO0E+OO,O.O0OOE+0O, 0 . OOOOE+00 , 0 . OOOOE+00 , 0. OOOOE+00, 
0 . OOOOE+00, 0 . OOOOE+00., 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE + 00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 
0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 
0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 
0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 
0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE+00 , 
0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 
0 .OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00 , 0. OOOOE+00/ 
DATA {PCGTF3 (I) ,1=51,100)/ 

0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 
0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 
0 . OOOOE + 00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0 . OOOOE + 00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, O.OOOOE+00, 
0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00/ 
DATA (PCGTF3 (I) , 1=101, 150) / 

0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 
0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0 . OOOOE+00, 0 . OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00 , 
0 . OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 
0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00 , 
0 . OOOOE+00, 0 . OOOOE+00, 0. OOOOE + 00, 0 . OOOOE+00 , 0 . OOOOE+00 , 
0. OOOOE+00, 0 . OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 0. OOOOE+00, 
0. OOOOE+00, 0.2036E-05,0. 4190E- 05, 0.6583E-05, 0.9331E-05, 
0.1256E-04, 0.163 7E- 04,0. 2091E- 04, 0.262 7E- 04,0. 3258E- 04/ 
DATA (PCGTF3 (I) , 1=151,200) / 

0.3997E-04, 0.4852E-04, 0. 5826E-04, 0.6919E-04, 0.812 9E-04, 
0.9459E-04, 0.1091E-03,0.1247E-03, 0.1415E-03, 0.1595E-03, 
0.1787E-03, 0.1991E-03,0.2206E-03, 0.2433E-03, 0.2673E-03, 
0.2928E-03, 0.3200E-03,0.34 92E-03, 0.3805E-03, 0.4142E-03, 
0.4506E-03, 0.4898E-03, 0.5321E-03, 0.5776E-03, 0.6267E-03, 
0.6795E-03, 0.7362E- 03,0. 7973E- 03,0. 8631E-03,0.9339E- 03, 
O.lOlOE-02, 0.1092E-02, 0.1180E-02, 0.1275E-02, 0.1377E-02, 
0.1486E-02, 0.1602E-02, 0.1726E-02, 0.1859E-02, 0.2 001E-02, 
0.2151E-02, 0.2311E-02,0.2481E-02, 0.2661E-02,0.2852E-02, 
0.3053E-02, 0.3266E-02,0.3490E-02, 0.3726E-02, 0.3975E-02/ 
DATA (PCGTF3 (I) ,1=201,250)/ 

0.4237E-02, 0.4511E-02,0.4798E-02, 0.5097E-02, 0.5406E-02, 
0.5727E-02,0.6057E-02,0.6397E-02,0.6746E-02,0,7102E-02, 
0.7466E-02, 0.783 7E-02,0.8214E-02, 0.8597E-02, 0.8 984E-02, 
0.9376E-02, 0.9772E-02,0.1017E-01, 0.1057E-01,0.1097E-01, 
0,1138E-01, 0.1178E-01,0.1219E-01, 0.12 59E-01, 0.1299E-01, 
0. 133 9E-01, 0.13 79E-01, 0.1419E- 01, 0.1458E- 01,0, 1498E-01, 
0.1537E-01, 0.1577E-01,0.1617E-01, 0.1657E-01, 0.1697E-01, 
0.1738E-01, 0.1779E-01,0.1821E-01, 0.1864E-01, 0.1907E-01, 
0.1951E-01, 0 .1996E-01, 0 .2041E-01, 0 .2088E-01, 0.2136E-01, 
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0.2185E-01, ^j^35E-01, 0.2287E-01, 0.2340E-01, ^^94E-01/ 
DATA (PCGTF3 (I) ,1=251,300)/ 

0.2450E-01, 0.2508E-01, 0.2567E-01, 0.2628E-01, 0.2690E-01, 
0.2 753E-01, 0. 2818E-01, 0 .2884E-01, 0.2 951E-01, 0. 3020E-01, 
0.3089E-01, 0.3160E-01, 0.3231E-01,0.3304E-01, 0. 3377E-01, 
0.3452E-01, 0.3 527E-01, 0.3602E-01, 0.3679E-01, 0.3756E-01, 
0.3834E-01, 0.3912E-01, 0.3 990E-01, 0.406 9E-01, 0.4149E-01, 
0.4228E-01, 0.4308E-01, 0.4388E-01, 0.4468E-01, 0.4548E-01, 
0.4629E-01, 0.4709E-01, 0.4789E-01, 0.486 9E-01, 0.494 9E-01, 
0 . 5028E-01, 0 . 5107E-01, 0. 5186E-01, 0 . 5264E-01, 0. 5342E-01, 
0. 5419E-01, 0. 54 96E-01, 0. 5572E-01, 0.5648E-01, 0. 5722E-01, 
0. 5796E-01, 0. 5869E-01, 0. 5941E-01, 0.6012E-01, 0.6082E-01/ 
DATA (PCGTF3 (I) ,1=301,350)/ 

0.6151E-01, 0.6219E-01, 0.6285E-01, 0.6351E-01, 0.6416E-01, 
0. 6479E-01, 0. 6542E-01, 0. 6604E-01, 0.6665E-01, 0.6726E-01, 
0.6785E-01, 0.6844E-01, 0.6902E-01, 0.696 0E-01, 0.7017E-01, 
0.7074E-01, 0.7130E-01, 0.7186E-01, 0.7241E-01, 0.72 96E-01, 
0. 7351E-01, 0. 7406E-01, 0. 7460E-01, 0.7515E-01, 0.7569E-01, 
0.7623E-01, 0.7677E-01, 0. 7732E-01, 0.7786E-01, 0.7841E-01, 
0.78 96E-01, 0. 7951E-01, 0 . 8006E- 01 , 0 . 8062E- 01 , 0.8118E-01, 
0.8174E-01, 0.8231E-01, 0. 8289E-01, 0 . 8347E- 01 , 0 . 8405E- 01 , 
0. 8465E-01, 0 . 8525E-01, 0. 8586E-01, 0 .864 7E-01, 0.8710E-01, 
0.8773E-01, 0.883 7E-01, 0.8902E-01, 0.8969E-01, 0.9036E-01/ 
DATA {PCGTF3 (I) , 1 = 351,400) / 

0 . 9105E-01, 0 . 9174E-01, 0. 9245E-01, 0 . 9317E-01, 0 . 93 90E-01, 
0.9464E-01, 0.954 0E-01, 0. 9616E-01,0. 9693E-01, 0.9772E-01, 
0.9851E-01, 0. 9931E-01, O.lOOlE+00, 0.1009E+00, 0.1018E+00, 
0 . 1026E+00 , 0 . 1035E+00 , 0 . 1043E+00 , 0 . 1052E+00 , 0 . 1061E+00 , 
0.1070E+00,0.1078E+00, 0.1087E+00, 0.1097E+00, 0.1106E+00, 
0.1115E+00, 0.1124E+00,0.1133E+00, 0.1143E + 00, 0.1152E+00, 
0,X162E+00,0.1171E+00,0. 1181E+00,0.1191E+00, 0.12 01E+00, 
0.1210E+00, 0. 122 0E+00, 0. 1230E+00, 0 . 1240E+00 , 0 . 1250E+00 , 
0 . 1260E+00, 0 . 1270E+00 , 0 . 1280E+00 , 0 . 12 90E+00 , 0 . 13 01E+00 , 
0.1311E+00, 0.1321E+00, 0.1331E+00, 0.1342E+00, 0.1352E+00/ 
DATA (PCGTF3 (I) , 1=401,450) / 

0.1362E+00, 0.1373E+00, 0.1383E+00,0. 13 94E+00, 0.1404E+00, 
0 . 1414E+00 , 0 . 142 5E+00 , 0 . 1435E+00 , 0 . 1446E+00 , 0 . 14 56E+00 , 
0. 1467E+00, 0 . 1478E+00, 0 . 1488E+00 , 0 . 14 99E+00 , 0.1509E+00, 
0.1520E+00, 0.1530E+00, 0 . 1541E+00 , 0 . 1552E+00 , 0 . 1562E+00 , 
0 . 1573E+00 , 0 . 1584E+00 , 0 . 1594E+00 , 0 . 1605E+00 , 0 . 1616E+00 , 
0.1626E+00, 0.163 7E+00, 0 . 1648E+00 , 0 . 1658E+00 , 0.1669E+00, 
0 .1680E+00, 0 . 1690E+00, 0 . 1701E+00 , 0 . 1712E+00 , 0 . 1722E+00 , 
0.1733E+00, 0.1744E+00,0.1754E+00,0.1765E+00, 0.1776E+00, 
0 . 1786E+00, 0 . 1797E+00, 0 . 1807E+00 , 0 . 1818E+00 , 0 . 1829E+00 , 
0. 1839E+00, 0 . 1850E+00, 0 . 1860E+00 , 0 . 1871E+00 , 0 . 1882E+00/ 
DATA (PCGTF3 (I) ,1=451,500)/ 

0. 1892E+00, 0 . 1903E+00, 0 . 1913E+00 , 0 . 1924E+00 , 0 . 1934E+00 , 
0 . 1945E+00, 0 . 1955E+00 , 0 . 1965E+00 , 0 . 1976E+00 , 0 . 1986E+00 , 
0. 1997E+00, 0.2007E+00, 0 . 2017E+00 , 0 . 2027E+00 , 0 . 2038E+00 , 
0 , 2048E+00, 0 .2058E+00, 0 . 2068E+00 , 0 . 207 9E+00 , 0 . 208 9E+00, 
0.2099E+00, 0 .2109E+00, 0 .2119E+00, 0. 212 9E+00, 0.2139E+00, 
0.214 9E-f00, 0.2159E+00, 0 . 2169E+00 , 0 . 2179E+00 , 0 . 2189E+00 , 
0.2198E+00, 0.2208E+00, 0.2218E+00, 0.2227E+00, 0.2237E+00, 
0.2247E+00, 0 .2256E+00, 0 .2266E+00, 0.2275E+00, 0.2285E+00, 
0.2294E+00, 0.2304E+00, 0.2313E+00, 0.2322E+00, 0.2331E+00, 
0.2341E+00, 0.2350E+00, 0,2359E+00, 0.2368E+00, 0.23 77E+00/ 
DATA (PCGTF3 (I) , 1=501,550)/ 

0. 2386E+00, 0 .2395E+00, 0 .2404E+00, 0.2412E+00, 0.2421E+00, 
0.2430E+00, 0 .243 9E+00, 0 .2447E+00, 0.2456E+00, 0.2464E+00, 
0.2473E+00, 0.2481E+00, 0 . 2490E+00 , 0 . 2498E+00 , 0 . 2506E+00 , 



0.2515E+00,T^523E+00,0.2531E+00, 0.2539E+00, 072547E+00, 

0.2555E+00, 0.2563E+00,0.2571E+00, 0.2579E+00, 0.2587E+Oo! 

0.2595E+00,0.2603E+00,0.2611E+00, 0.2619E+00,0.2626E+Ool 

0.2634E+00,0.2642E+00,0.2649E+00, 0.2657E+00,0.2664E+00, 

0.2672E+00,0.2680E+00,0.2687E+00, 0.2694E+00,0.2702E+00,' 

0.2709E+00,0.2717E+00,0.2724E+00,0.2731E+00, 0.2739S+Oo! 

0.2746E+00, 0.2753E+00, 0.2760E+00, 0.2768E+00, 0.27752+00/ 
DATA (PCGTF3 (I) ,1=551,600)/ 

0.2782E+00,0.2789E+00,0.2796E+00,0.2803E+00,0.2810E+00, 
0.2817E+00, 0.2824E+00,0.2831E + 00, 0.2838E+00, 0.2845S+00,' 
0.2852E+00,0.2859E+00,0.2866E + 00, 0.2873E+00, 0.28803+00,' 
0.2887E+00, 0.2894E+00,0.2900E+00, 0.2907E+00, 0.2914S+Oo! 
0.2921E+00, 0.2928E+00, 0.2934E+00, 0.2941E+00, 0.2948E+Oo! 
0.2955E+00, 0.2961E+00,0.2968E+00, 0,2975E+00, 0.2982S+00,' 
0.2988E+00,0,2995E+00,0.3002E+00, 0.3008E+00,0. 301SE+00,' 
0.3022E+00,0.3028E+00,0.303 5E+00, 0.3 042E+00,0.3 048S+Oo! 
0.3055E+00, 0.3062E+00, 0. 3069E+00, 0.3075E + 00, 0.3 082S+00,' 
0 . 3089E+00 , 0 . 3095E+00 , 0 . 3102E+00 , 0 . 3109E+00 , 0 .31152+00/ 
DATA {PCGTF3 (I) ,1=601,650)/ 

0.3122E+00, 0.3129E+00, 0.3135E+00, 0. 3142E+00, 0.314S3+00, 
0.3156E+00, 0.3162E+00, 0.3169E+00, 0.3176E+00, 0.31822+00 ! 
0.3189E+00, 0.3196E+00, 0.3203E+00, 0.3209E+00, 0. 32162+00 ! 
0.3223E+00, 0.3230E+00, 0.323 7E+00, 0.3243E+00, 0.32502+00, 
0.3257E + 00, 0.3264E+00, 0.3270E + 00, 0. 3277E+00, 0.32842+00,' 
0 . 3291E+00 , 0 . 3298E+00 , 0 . 3304E+00 , 0 . 3311E+00, 0 . 33182+00 \ 

0.3325E+00, 0.3332E+00, 0.3339E+00, 0.3345E+00, 0.33522+00,' 
0.3359E+00, 0.3366E+00, 0.3373E+00, 0.3379E+00, 0.33862+00,' 
0. 33 93E+00, 0.34 OOE+00, 0.3407E+00, 0.3414E+00, 0.34212+00! 
0.3427E+00, 0.3434E+00, 0.3441E+00, 0.3448E+00, 0.34552+00/ 
DATA (PCGTF3 (I) , 1=651, 700) / 

0.3462E+00,0.3469E+00, 0.3475E+00, 0.3482E+00, 0.348S2+00, 

0.3496E+00, 0.3503E+00, 0.3510E+00, 0.3517E+00, 0.35232+00,' 

0.3530E+00, 0.3537E+00, 0.3544E+00, 0.3551E + 00, 0.35582+00 ! 

0.3565E+00, 0.3572E+00, 0.3578E+00, 0.3585E+00, 0 .35923+00,' 

0.3599E+00, 0.3606E+00, 0.3613E+00, 0.3620E+00, 0.36272+00 ! 

0.3634E+00, 0.3640E+00, 0.3647E+00, 0.3654E + 00, 0.36612+00,' 

0.3668E+00, 0.3675E+00, 0.3682E+00, 0.3689E+00, 0.36952+00 ! 

0.3702E+00, 0.3709E+00, 0.3716E+00, 0.3723E+00, 0.37302+00! 

0.3737E+00,0.3743E+00, 0.3750E+00, 0.3757E+00, 0.37642+00,' 

0.3771E+00, 0.3778E+00, 0.3785E+00, 0.3792E+00, 0.37982+00/ 
DATA (PCGTF3 (I) , 1=701, 750) / 

0.3805E+00,0.3812E+00,0.3819E+00, 0.3826E+00, 0.38332+00, 
0.3839E+00, 0.3846E+00, 0.3853E+00, 0.3860E + 00, 0.38673+00 ! 
0.3874E+00,0.3880E+00, 0.3887E+00, 0.3894E+00, 0.39013+00 ! 
0 . 3908E+00, 0 . 3915E+00 , 0 . 3921E+00 , 0 . 3928E+00, 0 . 39352+00 \ 

0.3942E+00, 0.3949E+00, 0. 3 955E+00,0.3962E+00,0. 39692+00 ! 
0 . 3976E+00, 0 . 3983E+00 , 0 . 3989E+00 , 0 . 3996E+00 , 0 .40032+00 \ 

0.4010E+00,0.4016E+00, 0.4023E+00, 0.4030E+00, 0.40372+00,' 
0.4044E+00, 0.4050E+00, 0.4057E+00, 0.4064E+00, 0.40703+00 ! 
0.4077E+00, 0.4084E+00, 0.4091E + 00, 0.4097E+00, 0.41042+00,' 
0.4111E+00, 0.4117E+00, 0.4124E+00, 0.4131E+00, 0.41382+00/ 
DATA (PCGTF3 (I) ,1=751,800)/ 

0.4144E+00,0.4151E+00,0.4158E+00,0.4164E+00, 0.41712+00, 
0.4178E+00,0.4184E+00, 0.4191E+00,0.4197E+00, 0.42043+00! 
0.4211E+00,0.4217E+00,0.4224E+00,0.4231E+00,0.42372+Oo! 
0.4244E+00,0.4250E+00, 0.4257E+00, 0.4264E+00, 0.42703+00 ! 
0.4277E+00,0.4283E+00,0.4290E+00,0.4296E+00,0.4303E+Oo! 
0.4309E+00,0.4316E+00, 0.4322E+00, 0.4329E+00, 0.43352+00! 
0.4342E+00,0.4348E+00, 0.4355E+00,0.4361E+00, 0.43682+00 ! 
0.4374E+00,0.4381E+00, 0.4387E+00,0.4394E+00, 0.44002+00! 



0.4406E+00, 0^Wl3E+00, 0.4419E+00, 0.4426E+00, 0.4432E+00, 
0.4438E+00, 0.4445E+00, 0.4451E+00, 0.4458E + 00, 0.4464E + 00/ 
DATA (PCGTF3 (I) ,1=801,850)/ 

0.4470E+00, 0.4474E+00,0.4478E+00, 0.4481E+00, 0.4485E+00, 
0.4489E+00, 0.4493E+00,0.4497E+00, 0.4500E+00, 0.4504E+00, 
0.4508E+00, 0.4512E+00, 0.4516E+00, 0.4519E + 00, 0.4523E+00, 
0.4527E+00, 0.4531E+00, 0.4535E+00, 0.4538E+00, 0.4542E+00, 
0.4546E+00, 0.4550E+00,0.4554E+00, 0.4558E+00, 0.4 561E+00, 
0.4565E + 00, 0.4569E+00,0.4573E+00, 0.4577E+00, 0.4581E+00, 
0.4584E + 00, 0.4588E+00, 0.4592E+00, 0.4596E+00, 0.4600E+00, 
0.4604E+00, 0.4608E+00, 0.4612E+00, 0 .4615E + 00, 0.4619E+00, 
0.4623E+00, 0.4627E+00, 0.4631E+00, 0.4635E+00, 0.4639E+00, 
0.4643E+00, 0.4647E+00, 0.4650E+00, 0.4654E+00, 0.4658E+00/ 
DATA (PCGTF3 (I) ,1 = 851, 900) / 

0.4662E+00, 0.4666E+00,0.4670E+00, 0.4674E+00, 0.46 78E+00, 
0.4682E+00, 0.4686E+00,0.4690E+00, 0.4694E+00, 0.46 98E+00, 
0.4702E+00, 0.4706E+00, 0.4710E+00, 0 . 4 713E+00 , 0 . 4 717E+00 , 
0.4721E+00, 0.4725E+00,0.4729E+00, 0.4733E+00, 0.4 737E+00, 
0.4 741E+00, 0.4745E+00, 0.474 9E+00, 0 . 4 753E+00 , 0 . 4 757E+00 , 
0.4 761E+00, 0. 4765E+00, 0 .4769E+00, 0 . 4773E+00, 0 .4777E+00, 
0.4781E + 00, 0.4785E+00,0.4789E+00, 0.4 793E+00, 0.4 798E+00, 
0.4802E+00, 0.4806E+00, 0.4810E+00, 0.4814E+00, 0.4818E+00, 
0.4822E+00, 0.4826E+00, 0 .483 0E+00, 0 . 4834E+00 , 0 . 4838E + 00 , 
0.4842E + 00, 0.4846E+00, 0.48 50E+00, 0.4854E+00, 0.4858E + 00/ 
DATA (PCGTF3 (I) ,1=901,950)/ 

0.4863E+00, 0.4867E+00, 0.4871E+00, 0.4 875E+00, 0.4879E+00, 
0.4883E+00, 0.4887E+00, 0.4891E+00, 0.48 95E+00, 0.4899E+00, 
0.4904E+00, 0.4908E+00, 0.4912E+00, 0.4916E+00, 0.4920E+00, 
0.4924E+00, 0.4928E+00, 0.4933E+00, 0.4937E + 00, 0 .4941E+00, 
0.4945E + 00, 0.4949E+00, 0.4953E+00, 0.4958E+00, 0.4962E+00,' 
0.4966E+00, 0.4970E+00, 0.4974E+00,0.4978E+00, 0.4983E+00, 
0.4987E+00,0.4991E+00, 0.4995E+00, 0.4999E + 00, 0. 5004E+00, 
0 . 5008E+00 , 0 . 5012E+00, 0 . 5016E+00, 0 . 5020E+00 , 0 . 5025E+00, 
0 . 5029E+00, 0 . 5033E+00, 0 . 5037E+00, 0 . 5042E+00, 0 . 5046E+00, 
0 . 5050E+00, 0 . 5054E+00, 0 . 5059E+00, 0 . 5063E+00, 0 . 5067E+00 / 
DATA (PCGTF3{I) ,I=951,Nrigs)/ 

0 . 5071E+00, 0 . 5076E+00, 0 . 5080E+00 , 0 . 5084E+00 , 0 . 5088E+00 , 
0 , 5093E+00 , 0 . 5097E+00, 0 . 5101E+00 , 0 . 5106E+00 , 0 . 5110E+00 , 
0.5114E+00,0.5119E+00,0.5123E+00,0. 5127E+00, 0.5131E+00, 
0 . 5136E + 00, 0 . 5140E+00, 0 . 5144E+00 , 0 . 514 9E+00 , 0 . 5153E+00, 
0 . 5157E+00 , 0 . 5162E+00, 0 . 5166E+00 , 0 . 5170E+00 , 0 . 5175E+00 ! 
0 . 5179E+00, 0 . 5184E+00, 0 . 5188E+00 , 0 . 5192E+00 , 0 . 5197E+00,' 
0 . 5201E+00 , 0 . 5205E+00, 0 . 5210E+00 , 0 . 5214E+00 , 0 . 5219E+00 , 
0. 5223E+00, 0. 5227E+00, 0 . 5232E+00, 0 . 5236E+00, 0 . 5241E+00,' 
0 . 5245E+00, 0 . 5249E+00, 0 . 5254E+00 , 0 . 5258E+00, 0 . 5263E+00, 
0 . 5267E+00, 0 . 5271E+00 , 0 . 5276E+00, 0 . 5280E+00 , 0 . 5285E+00 \ 
0.5289E+00/ 

DATA (PCGTF4 (I) ,1=1,50)/ 

0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 
0 . OOOOR+00, 0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00,' 
0 . OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00,' 
0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+OO, 0 . OOOOE+00 \ 
0 . OOOOE+OO , 0 . OOOOE+00, 0 . OOOOE+OO , 0 . OOOOE+OO , 0 . OOOOE + 00 ,' 
O.OOO0E+OO,0.O0OOE+0O,0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+00,' 
0. OOOOE+OO, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00, 0 .OOOOE+00 ! 
0. OOOOE+OO, 0. OOOOE+00, 0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+00,' 
0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+00, 0. OOOOE+00, 0. OOOOE+00 i 
0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+OO/ 
DATA {PCGTF4 (I) ,1=51,100)/ 

0 . OOOOE + OO, 0 . OOOOE+OO , 0 . OOOOE+00 , 0 . OOOOE+OO, 0 . OOOOE+OO , 




# 0. OOOOE+00,^^OOOE+00, O.OOOOE+00, 0 .OOOOE+00, O^OOOE+00, 

# 0 . OOOOE+00, 0 . OOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 

# 0 . OOOOE+00, 0 . pOOOE+00, 0. OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+00, 

# 0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 

# 0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE+00,, 0 . OOOOE+00 , 0 . OOOOE+00 , 

# 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 0 . OOOOE+00 , 

# 0 . OOOOE+00 , 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+OO, 0 , OOOOE+00 , 

# 0 . OOOOE+OO , 0 . OOOOE+OO, 0 . OOOOE+OO, 0 . OOOOE+OO , 0 . OOOOE+OO , 

# 0 . OOOOE+OO , 0 . OOOOE+00, 0 . OOOOE+00, 0 . OOOOE+OO , 0 . OOOOE+OO / 
DATA (PCGTF4 (I) ,1=101,150)/ 

# 0 . OOOOE+OO , 0 . OOOOE+OO , 0 . OOOOE+00, 0 . OOOOE+OO , 0 . OOOOE+OO , 

# 0. OOOOE+OO, 0. OOOOE+00, 0. OOOOE+OO, 0. OOOOE+00, 0. OOOOE+OO, 

# 0 . OOOOE+00, 0. OOOOE+OO, 0. OOOOE+OO, 0 . OOOOE+OO, 0 . OOOOE+00, 

# 0 . OOOOE+OO , 0 . OOOOE+OO , 0 . OOOOE+OO, 0 . OOOOE+OO , 0 . OOOOE+OO , 

# 0. OOOOE+OO, 0 . OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+OO, 

# 0. OOOOE+OO, 0. OOOOE+OO, 0. OOOOE+OO, 0 . OOOOE+OO, 0 . 1998E-04 , 

# 0.3 997E-04,0.5863E-04, 0.7762E-04, 0. 9727E-04, 0.1179E-03, 

# 0.1399E-03, 0. 1636E-03, 0.1896E-03, 0.2185E-03, 0.2510E-03, 

# 0.2878E-03, 0.3293E-03, 0.3757E-03, 0.4268E-03, 0.4827E-03, 

# 0.5433E-03,0.6086E-03,0.6784E-03, 0. 7529E-03, 0.8318E-03/ 
DATA (PCGTF4 (I) , 1=151,200) / 

# 0.9153E-03, 0. 1003E-02,0.1096E-02, 0.1195E-02, 0.1299E-02, 

# 0.1410E-02, 0. 1528E-02,0.1653E-02, 0.1787E-02, 0.192 9E-02, 

# 0.2081E-02, 0.2242E-02,0.2413E-02, 0.2595E-02, 0.2788E-02, 

# 0.2 991E-02, 0.3205E-02,0.3428E-02, 0.3660E-02, 0.3 901E-02, 

# 0.4151E-02, 0.4409E-02, 0.46 75E-02, 0.4948E-02, 0. 522 9E-02, 

# 0.5516E-02, 0.5809E-02,0.6109E-02, 0.6416E-02, 0.6 730E-02, 
0.7052E-02, 0.7381E-02,0.7719E-02,0.8064E-02, 0.8419E-02, 
0.8782E-02,0.9154E-02,0.9536E-02, 0.9928E-02, 0.1033E-01, 
0.1074E-01, 0.1116E-01,0.1160E-01, 0.1204E-01, 0.1250E-01, 
0. 12 96E-01, 0.1344E-01, 0.13 94E-01, 0.1444E-01, 0.1496E-01/ 
DATA {PCGTF4 (I) , 1=201,250) / 

0. 1549E-01, 0.1603E-01,0.1659E-01,0.1715E-01, 0.1773E-01, 
0.1832E-01, 0.1892E-01,0.1952E-01,0.2013E-01, 0.2074E-01, 
m ^ 0-2136E-01, 0.2198E-01,0.2261E-01, 0.2323E-01, 0.2386E-01,' 

y # 0.2448E-01, 0.2510E-01,0.2572E-01,0.2634E-01, 0.2695E-01, 

£2 ^ 0-2755E-01, 0.2815E-01,0.2874E-01, 0.2932E-01, 0.2990E-01, 

[fi # 0.3 046E-01, 0.3100E-01,0.3154E-01, 0.3207E-01, 0.3259E-01, 

# 0- 3310E-01, 0.3360E-01,0.3410E-01,0.3459E-01, 0.3508E-01, 
^ 0. 3 556E-01, 0.3604E-01, 0.3652E-01, 0.3 700E-01, 0 . 3 748E-01, 

# 0.3796E-01, 0.3844E-01, 0.3893E-01, 0.3942E-01, 0.3992E-01,' 

# 0.4042E-01,0.4093E-01,0.4145E-01,0.4197E-01,0.4251E-01/ 
DATA (PCGTF4 (I) , 1=251,300) / 

# 0.4306E-01,0.4362E-01,0.4419E-01, 0.4477E-01, 0.4536E-01, 

# 0.4596E-01,0.4658E-01,0.4720E-01,0.4783E-01, 0.4847E-01, 

# 0.4912E-01,0.4978E-01,0.5044E-01, 0.5111E-01, 0.5179E-01, 

# 0.5248E-01,0.5317E-01,0.5386E-01,0.5457E-01,0.5527E-01, 

# 0.5598E-01,0.5670E-01,0.5742E-01,0.5814E-01, 0.5886E-01, 

# 0.5959E-01,0.6032E-01,0.6105E-01, 0.6178E-01,0.6251E-01, 

# 0.6324E-01, 0.6397E-01,0.6470E-01, 0.6543E-01,0.6616E-01, 

# 0.6689E-01, 0.6762E-01, 0.6834E-01, 0.6906E-01, 0.6978E-01, 

# 0 . 7049E-01 , 0 . 7120E-01, 0 . 7191E-01 , 0 . 7261E-01 , 0 . 7331E-01 ] 

# 0.7399E-01, 0.7468E-01,0.7536E-01, 0.7603E-01,0.7669E-01/ 
DATA (PCGTF4 (I) , 1=301,350) / 

# 0.7735E-01,0.7799E-01,0.7863E-01, 0.7927E-01,0.7989E-01, 

# 0.8051E-bl,0.8112E-01,0.8173E-01,0.8233E-01, 0.8293E-01, 

# 0.8352E-01, 0.8411E-01,0.8469E-01, 0.8527E-01, 0.8585E-01, 

# 0.8642E-01, 0.8699E-01,0.8756E-01, 0.8813E-01, 0.8869E-01, 

# 0 . 8926E-01, 0 . 8982E-01, 0 . 9038E-01, 0 . 9095E-01, 0 . 9151E-01, 

# 0. 9208E-01, 0 . 9264E-01, 0 . 9321E-01, 0 . 9378E-01, 0 . 9435E-01, 



# 



0 . 9492E-01, 0^550E-01, 0 . 9607E-01, 0 . 9666E-01, 0 . 9724E-01, 
0.9784E-01, 0.9843E-01, 0. 9903E-01,0.9964E-01, 0. 1003E+00, 
0.1009E+00, 0. 1015E+00, 0. 1021E+00, 0.1028E+00, 0.1034E+00, 
0.1041E+00, 0. 1047E+00, 0. 1054E+00, 0.1061E+00, 0.1068E+00/ 
DATA (PCGTF4 (I) ,1 = 351,400)/ 

0.1075E+00, 0.1082E+00, 0.1089E+00, 0.1096E+00, 0. 1104E+00, 
0 . llllE+00 , 0 . 1119E+00 , 0 . 1126E+00 , 0 . 1134E+00 , 0 . 1142E+00, 
0. 1150E+00, 0 . 1158E+00, 0. 1166E+00, 0. 1174E+00, 0. 1182E+00, 
0.1191E+00, 0.1199E+00,0.1208E+00,0.1216E+00,0.1225E+00, 
0.1233E+00, 0.1242E+00, 0.1251E+00, 0.1260E+00, 0.1268E+00, 
0 . 1277E+00 , 0 . 1286E+00 , 0 . 1295E+00 , 0 . 1304E+00 , 0 . 1314E+00, 
0.132 3E+00, 0 . 1332E+00, 0. 1341E+00, 0.1350E+00, 0.1360E+00, 
0.1369E+00, 0 .1379E+00, 0.1388E+00, 0.1397E+00, 0.1407E+00, 
0 . 1416E+00 , 0 . 1426E+00 , 0 . 143 5E+00 , 0 . 1445E+00 , 0 . 1454E+00 , 
0 . 1464E+00, 0 . 1474E+00, 0 . 1483E+00 , 0 . 1493E+00 , 0 . 1502E+00/ 
DATA (PCGTF4 (I) ,1=401,450) / 

0.1512E+00, 0.1522E+00, 0.1531E+00, 0.1541E+00, 0.1550E+00, 
0.156 0E+00, 0.1570E+00, 0.1579E+00, 0.1589E+00, 0.1598E+00, 
0.1608E+00,0.1618E+00,0.162 7E+00,0.163 7E+00,0,164 7E+00, 
0. 1656E+00, 0 . 1666E+00, 0, 1675E+00, 0.1685E+00, 0.16 95E+00, 
0.1704E+00,0.1714E+00, 0.1723E+00,0.1733E+00,0.1743E+00, 
0.1752E+00, 0.1762E+00, 0.1771E+00,0.1781E+00, 0.1791E+00, 
0 . 1800E+00, 0 . 1810E+00 , 0 . 1819E+00, 0 . 1829E+00 , 0 . 183 8E+00 , 
0 . 1848E+00, 0 . 1858E+00 , 0 . 1867E+00 , 0 . 1877E+00, 0 . 1886E+00, 
0.1896E+00, 0.1905E + 00, 0.1915E+00, 0.1925E+00, 0.1934E+00, 
0.1944E+00, 0.1953E+00, 0.1963E+00,0.1972E+00,0.1982E+00/ 
DATA (PCGTF4 (I) , 1=451, 500) / 

0 . 1991E+00 , 0 . 2 001E + 00 , 0 . 2 010E+00 , 0 . 2020E+00 , 0 . 2029E+00 , 
0.203 9E + 00, 0.2048E+00, 0.2 058E+00,0.2067E+00, 0.2077E + 00, 
0 . 2086E+00 , 0 . 2096E+00 , 0 . 2105E+00 , 0 . 2115E+00 , 0 . 2124E+00 , 
0.2134E+00, 0. 2143E+00, 0.2153E+00, 0.2162E+00, 0.2172E+00, 
0.2181E+00, 0.2191E+00, 0 .22 00E+00, 0.2209E+00, 0.2219E+00, 
0.2228E+00, 0.2238E+00, 0 . 2247E+00 , 0 . 22 56E+00 , 0 . 2266E+00 , 
0.2275E+00, 0.2285E+00, 0.2294E+00, 0.2303E+00,0.2313E+00, 
.0.2322E+00, 0.2331E+00, 0.2341E+00,0.2350E+00, 0 .2359E+00, 
0.2369E+00, 0.2378E+00, 0.2387E+00, 0.2396E+00,0 .2406E+00, 
0.2415E+00, 0. 2424E+00, 0 .2434E+00, 0.2443E+00, 0 .24 52E+00/ 
DATA (PCGTF4 (I) , 1=501, 550) / 

0.2461E+00, 0.24 71E+00, 0.2480E+00, 0.2489E+00, 0.24 98E+00, 
0.2507E+00, 0.2517E+00, 0.2526E+00, 0.2535E+00, 0.2544E+Oo] 
0.2553E+00,0.2562E+00, 0.2571E+00, 0.2581E+00, 0.2590E+00, 
0.2599E+00,0.2608E+00, 0.2617E+00, 0.2626E+00, 0.2635E+00, 
0.2644E+00,0.2653E+00, 0.2662E+00, 0.2671E+00, 0.2680E+00, 
0.2689E+00, 0.2698E+00, 0 .2707E+00, 0.2716E+00, 0.2 725E+00, 
0.2734E+00, 0.2743E+00, 0.2752E+00, 0.2760E+00, 0.2769E+00, 
0.2778E+00,0.2787E+00, 0.2796E+00, 0.2805E+00, 0.2813E+00, 
0 . 2822E+00 , 0 . 2831E+00 , 0 . 2840E+00 , 0 . 2848E+00 , 0 . 2857E+00 , 

0.2866E + 00, 0.2875E+00, 0.2883E+00, 0.2892E+00, 0.2901E+00/ 
DATA (PCGTF4 (I) ,1=551,600)/ 

0 . 2909E+00 , 0 . 2918E+00 , 0 . 2926E+00 , 0 . 2935E+00, 0 . 2944E+00, 
0.2952E+00,0.2961E+00, 0.2969E+00, 0.2978E+00, 0.2986E+Oo! 
0 . 2995E+00 , 0 . 3003E+00 , 0 . 3012E+00 , 0 . 3020E+00 , 0 . 3028E+00 , 
0 . 3037E+00, 0 . 3045E+00 , 0 . 3053E+00, 0 . 3062E+00, 0 . 3070E+00, 
0.3078E+00,0. 3087E+00, 0.3095E+00, 0.3103E+00, O.311IE+O0! 
0 . 3120E+00 , 0 . 3128E+00 , 0 . 3136E+00 , 0 . 3144E+00 , 0 . 3152E+00 , 

0.3160E+00, 0. 3168E+00, 0. 3176E+00, 0.3184E+00, 0 .3192E+00, 
0.3200E+00,0.3208E+00, 0.3216E+00, 0.3224E+00, 0.3232E+Oo! 
0.3240E+00,0.3248E+00, 0.3256E+00, 0.3263E+00, 0.3271E+00, 
0.3279E+00,0.3287E+00, 0.3294E+00,0.3302E+00, 0.3310E+00/ 
DATA (PCGTF4 (I) ,1=601,650) / 



i^^25E+00, 0.3333E+00, 0 . 3340E+00 



# 0. 3318E+00, 0^K25E+00, 0.3333E+00, 0 .3340E+00, ^348E+00, 

# 0.3355E+00,0.3363E+00,0.3370E+00, 0.3378E+00, 0.3385E+00, 

# 0 . 3393E+00 , 0 . 3400E+00 , 0 . 3408E+00 , 0 . 3415E+00 , 0 . 3422E+00 , 

# 0 . 3430E+00, 0 . 3437E+00, 0 . 3444E+00, 0 . 3451E+00, 0 . 3459E+00, 

# 0.3466E+00,0.34 73E+00,0.3480E+00, 0 . 3487E+00 , 0 . 34 94E+00 , 

# 0 . 3502E+00, 0 . 3509E+00 , 0 . 3516E+00, 0 . 3523E+00, 0 . 3 530E+00, 

# 0.3537E+00,0.3544E+00, 0.3551E+00, 0.3558E+00, 0 .3565E+00, 

# 0.3572E+00,0.3578E+00, 0.3585E+00, 0.3592E+00, 0.3599E+00, 

# 0. 3606E+00, 0. 3613E+00, 0. 3619E+00, 0.3626E+00, 0.3633E+00, 

# 0.3640E+00,0.3646E+00, 0.3653E + 00, 0.3660E+00, 0.3666E+00/ 
DATA (PCGTF4 (I) , 1=651, 700) / 

# 0 . 3673E+00, 0 . 3680E+00, 0 . 3686E+00, 0 . 3693E+00, 0 . 3699E+00, 

# 0 . 3706E+00, 0 . 3712E+00, 0 . 3719E+00, 0 . 3725E+00, 0 . 3 732E+00 , 

# 0.3738E+00, 0.374 5E+00, 0.3 751E+00, 0.3 758E+00, 0.3 764E+00, 

# 0 . 3771E+00, 0 . 3777E+00, 0 . 3783E + 00 , 0 . 3790E+00, 0 . 3796E+00 , 

# 0.3802E+00,0.3809E+00, 0.3815E+00, 0.3821E+00, 0.3 827E+00, 

# 0 . 3834E+00, 0 . 3840E+00, 0 . 3846E+00 , 0 . 3852E+00 , 0 . 3 858E+00, 

# 0.3865E+00, 0.3871E+00, 0.3877E+00,0.3883E+00, 0.3 889E+00, 

# 0 . 3895E+00 , 0 . 3 901E+00 , 0 . 3 907E+00 , 0 . 3 914E+00 ,0.3 920E+00 , 

# 0.3926E+00, 0.3932E+00, 0.3938E+00, 0.3 944E+00, 0. 3 950E+00, 

# 0.3956E+00, 0.3962E+00, 0.3968E+00, 0.3974E+00, 0. 3 980E+00/ 
DATA (PCGTF4 (I) , 1=701, 750) / 

# 0.3985E+00,0.3991E+00, 0.3997E+00, 0.4003E+00, 0.4 009E+00, 

# 0.4015E+00, 0.4 021E+00, 0.4027E+00, 0.4032E+00, 0.4 038E+00, 

# 0 .4044E+00, 0.4050E+00, 0.4056E+00, 0.4062E+00, 0. 4 06 7E+00, 

# 0 .4073E+00, 0 .4079E+00, 0.4085E+00, 0.4090E+00, 0.4096E+00, 

# 0.4102E+00, 0.4108E+00, 0.4113E+00, 0.4119E+00, 0.412 5E+00, 

# 0.4130E + 00, 0.4136E+00, 0.4142E + 00, 0.4147E+00, 0.4153E+00, 

# 0 .4159E+00, 0.4164E+00, 0.4170E+00, 0 .4176E+00, 0. 4181E+00, 

# 0.4187E + 00, 0 .4193E + 00, 0.4198E + 00, 0 . 4204E+00 , 0 . 42 09E+00 , 

# 0.4215E+00, 0.4221E-I-00, 0.4226E + 00, 0.4232E+00, 0.4237E+00, 

# 0.4243E+00, 0.4248E+00, 0.4254E+00, 0.4259E+00, 0.4265E+00/ 
DATA (PCGTF4 (I) , 1 = 751, 800) / 

# 0.42 70E+00, 0 .4276E+00, 0.4282E+00, 0 .4287E+00, 0 . 4293E+00, 

# 0.4298E+00, 0.43 04E+00, 0.43 09E + 00, 0.4315E+00, 0.4320E+00, 

# 0.4326E+00, 0.4331E+00, 0 .433 7E + 00, 0 . 4342E+00 , 0 . 4348E+00 , 

# 0 .4353E+00, 0.43 58E+00, 0.4364E + 00, 0 . 4369E+00 , 0 . 43 75E+00 , 

# 0.4380E+00, 0.4 386E+00, 0 .4391E + 00, 0 .43 97E+00, 0 .44 02E+00, 

# 0.4408E+00, 0.4413E+00, 0.4419E+00, 0.4424E+00, 0.442 9E+00, 

# 0.4435E + 00, 0.4440E+00, 0.4446E+00, 0.4451E+00, 0 .4457E+00, 

# 0 .4462E+00, 0.4467E+00, 0 .4473E+00, 0 .44 78E+00, 0 .4484E+00, 

# 0.4489E+00, 0,44 95E+00,0.4500E+00, 0.4506E+00, 0.4S11E+00, 

# 0.4516E+00,0.4522E+00, 0.4527E+00, 0.453 3E+00, 0.4538E+00/ 
DATA (PCGTF4 (I) ,1 = 801,850)/ 

# 0.4544E+00, 0.4547E+00, 0.4 551E+00, 0.4554E+00, 0.4558E+00, 

# 0.4561E+00,0.4565E+00, 0.4568E+00, 0.4571E+00, 0 .4575E+00, 

# 0.4578E+00, 0.4 582E+00, 0 .4585E + 00, 0 . 4589E+00 , 0 . 4592E+00 , 

# 0.4596E+00,0.4599E+00, 0.4603E+00, 0.4606E+00, 0.4610E+00, 

# 0 .4614E+00, 0.4617E+00, 0 .4621E+00, 0.4624E+00, 0 .4628E+00, 

# 0.4631E+00, 0.4635E+00, 0.4638E+00, 0 .4642E+00, 0 .4645E+00, 

# 0.4649E+00, 0.4652E+00, 0 .4656E+00, 0 .4659E+00, 0 .4663E+00, 

# 0. 4667E + 00, 0.4670E+00, 0 .4674E+00, 0 .4677E+00, 0 .4681E+00, 

# 0.4684E+00, 0.4688E+00, 0.4692E + 00, 0.46 95E+00, 0.46 99E+00, 

# 0.4702E + 00,0.4706E+00, 0.4709E+00, 0.4713E-»-00, 0.4 717E+00/ 
DATA {PCGTF4 (I) ,1 = 851,900)/ 

# 0.4720E + 00,0.4724E+00, 0.4727E+00, 0.4731E+00, 0.4735E+00, 

# 0.4738E+00,0.4742E+00, 0.4746E + 00, 0.4749E+00, 0 .4753E+00, 

# 0.4756E+00,0.4760E+00, 0.4764E+00, 0 . 4767E+00 , 0 . 4771E+00 , 

# 0.4775E+00,0.4778E+00, 0.4782E+00, 0.4785E+00, 0 .4789E+00, 

# 0.4793E+00,0.4796E+00, 0,4800E+00, 0 .4804E+00, 0.4807E+00, 



# 0.4811E+00, 0,^15E+00, 0.4818E+00, 0.4822E+00, 0.4826E+00, 

# 0.4829E+00, 0 .4833E+00, 0.4837E+00, 0 .4841E+00, 0.4844E+00, 

# 0.4848E+00, 0.48 52E+00, 0 .4855E+00, 0 .4859E+00, 0 .4863E+00, 

# 0.4866E+00, 0 .4870E+00, 0.4874E+00, 0.4878E+00, 0 . 4881E+00, 

# 0.4885E+00, 0.4 88 9E+00, 0.4892E+00, 0.4896E+00, 0.4 900E+00/ 
DATA (PCGTF4 (I) , 1 = 901, 950) / 

# 0.4904E+00, 0 .4907E+00, 0 .4911E+00, 0 .4915E+00, 0 . 4 919E+00, 

# 0.4922E+00, 0.4 926E+00, 0.4 930E+00, 0.4934E+00, 0 .4937E+00, 

# 0 .4941E+00, 0 .494 5E+00, 0 .4949E+00, 0 .4953E+00, 0 . 4 956E + 00, 

# 0.4960E+00, 0 .4964E+00, 0 .4968E+00, 0 .4971E+00, 0 . 4 975E+00, 

# 0.4 979E+00, 0.4 983E+00, 0.4987E+00, 0 .4990E+00, 0 .4994E+00, 

# 0.4998E+00, 0 . 5002E+00, 0 . 5006E+00, 0 . 5009E+00, 0 . 5013E+00, 

# 0.5017E+00, 0.5021E+00, 0.5025E+00, 0.5029E+00, 0. 5032E+00, 

# 0 . 5036E+00, 0 . 5040E+00, 0 . 5044E+00, 0 . 5048E+00; 0 . 5052E+00, 

# 0. 5056E+00, 0 . 5059E+00, 0. 5063E+00, 0 . 5067E+00, 0 . 5071E+00, 

# 0 . 5075E+00 , 0 . 507 9E+00, 0 . 5083E+00, 0 . 5086E+00 , 0 . 5090E+00 / 
DATA (PCGTF4 (I) , I=951,Nrigs) / 

# 0. 5094E+00, 0 . 5098E+00, 0 . 5102E+00, 0 . 5106E+00, 0 . 5110E+00, 

# 0.5114E+00,0.5118E+00, 0.5121E+00, 0.5125E+00, 0. 5129E+00, 

# 0. 5133E+00, 0 . 513 7E+00, 0 . 5141E+00, 0 . 514 5E+00, 0 . 514 9E+00, 

# 0 . 5153E+00, 0 . 5157E+00, 0 . 5161E+00, 0 . 5165E+00, 0 . 5169E+00, 

# 0. 5172E+00, 0. 5176E+00, 0 . 5180E+00, 0 . 5184E+00, 0 . 5188E+00, 

# 0. 5192E+00, 0 . 5196E+00, 0 . 5200E+00, 0 . 5204E+00, 0 . 5208E+00, 

# 0. 5212E+00, 0 . 5216E+G0, 0 . 5220E+00, 0 . 5224E+00, 0 . 5228E+00, 

# 0.5232E+00, 0. 5236E+00, 0.5240E+00, 0. 5244E+00, 0. 5248E+00, 

# 0.5252E+00, 0.5256E+00,0.5260E+00, 0.5264E+00, 0.5268E+00, 

# 0 . 52 72E+00, 0 . 5276E+00, 0 . 5280E+00 , 0 . 52 84E+00, 0 . 5288E+00 , 

# 0.5292E+00/ 

DO I=l,Nrigs 

RigBins ( I ) =RIGPC { I ) 
ENDDO 

RETURN 
END 




SUBROUTINE C^^rtTime (time, UTtimelnit, UT time, "zT^n, Period, 
# TimeLocal) 

C Calculate Universal Time and Local Time. Note that Zlon 

C and period are not both required. Used as a consistency check 

C here . 



IMPLICIT NONE 

REAL Time,UTtimeInit,UTtime, Zlon, Period, TimeLocal 
REAL secsperday 

PARAMETER (secsperday=86400 . 0) 
Integer Ndays , Ndaysloc 
REAL TimeLoc 



UTt ime=UTt imeini t + t ime 
Ndays=INT (UTtime/secsperday) 
UTtime=UTtime - Ndays* secsperday 

TimeLocal=UTtime+secsperday*Zlon/360 . 0 

IF (TimeLocal .GE. secsperday) TimeLocal=TimeLocal- secsperday 

RETURN 
END 



SUBROUTINE OutputTransFcn (RigBins , TransFunc , GtransFile , Orblncl , 

# Apogee , Perigee , AscNodeLong , AscNodeDisp , PerigDisp ' 

# Zenith, Azimuth, UTtimelnit , Stormy, Shadow, 

# PreCalcGTFs , IPreCalc , Year , XLbounds , 
^ ILbins, IprogNo) 

IMPLICIT NONE 

Format of header changed by AJT 8-21-96. 

File names for L-bin results changed from ,BN* to .GT* by AJT 11-6-96 

IF one L-bin specified with L_min > 0, make file extension .GTl 
instead of .GTF. 11-21-96, PRB. 

REAL Orblncl, Apogee, Perigee, AscNodeLong, AscNodeDisp, PerigDisp 

These variables are fixed at present and thus not included 

in header output . 

REAL Zenith, Azimuth, UTtimelnit 

Shadow is not checked in determining output, since all GTF 
calculations included in GEOMAG96 are omnidirectional averages. 

LOGICAL Shadow, Stormy, PreCalcGTFs , StormyPreCalc 

INTEGER IPreCalc 

Name of output file, thus not included in output file header 
CHARACTER*80 GtransFile , TempFile 



INTEGER I, Nrigs,NLvals,L, ILbins 





PARAMETER (Nrlf5=1001 , NLvals=10) 

REAL TransFunc (Nrigs,NLvals) , RigBins (Nrigs) 

REAL XLbounds (NLvals) , XLinf inite, Year 
PARAMETER (XLinf inite=l . OE+06) 

INTEGER ICREME96vno, IProgNo, IPreCalcOutput , IstormOutput 
INTEGER NHEADER,STAT,CREME96_OPEN 
DATA NHEADER/3/ 
CHARACTER* 9 CREATION_DATE 
CHARACTER* 8 CREATION TIME 



CHARACTER* 5 FEXT{10) 

DATA FEXT/' .GTl' , ' .GT2' , ' . GT3 ' , ' .GT4' , ' .GT5' , ' . GT6 ' , ' .GT7' , 
& ' . GTS ' , ' . GT9 ' , ' . GTX ' / 



CALL GET_CREME96_VERSION (ICREME96vno) 
IPreCalcOutput=0 

IF (PreCalcGTFs) THEN 

StormyPreCalc=. FALSE. I Local variable for header output file. 
IPreCalcOutput=l ! Local variable for header output file. 

IF ( (IpreCalc .EQ. 1) .OR. (IpreCalc .EQ. 3) ) 
& StormyPreCalc=.TRUE. 
ENDIF 

IStormOutput=0 

IF (StormyPreCalc .OR. Stormy) IStormOutput=l 

ILbins = 0 & ILbins = 1 from input routine are treated 
as ILbins = 1 for output, since they are stored in the 
same location in the array, 

IF (ILbins .EQ. 1 .AND. XLBOUNDS (1) .EQ. 0.0) THEN 

OPEN {UNIT=16,STATUS=' NEW ,FILE='USER: ' //GtransFile) 
Stat = creme96_open{gtransf ile, 'user' ,16, 'new' ) 
CALL DATE(CREATION_DATE) 
CALL TIME{CREATION_TIME) 

WRITE (16, 403) NHEADER, GTRANSFILE ( 1 : 70 ) , 
# ICREME96vno, IProgno 



WRITE(16, 992) 
WRITE (16, 404) 



ICREME96vno, CREATION_DATE, CREATION_TIME 
Orblncl , Apogee , Perigee , AscNodeLong , 
AscNodeDisp, PerigDisp 
IS tormoutput , IPrecalcOutput , Year , 
XLbounds (ILbins) , XLbounds (I lbins+1) 



# 



WRITE(16,405) 



# 



DO 1=1, Nrigs 



WRITE (16,410) RigBins ( I ) , TransFunc { I , ILbins ) 
ENDDO 
CLOSE (16) 



ELSE 



DO L=l,ILb! 

TEMPF I LE =G t r ans filed: index (gtransfile,' ')-!)/ / FEXT ( L ) 

OPEN (UNIT=16 , STATUS= ' NEW , FILE= ' USER : ' //GtransFile//FEXT (L) ) 
Stat = creme96_open(tempfile, 'user' , 16, 'new ) 
CALL DATE ( GREAT ION_DATE) 
CALL TIME(CREATION_TIME) 
WRITE (16, 4 03) NHEADER, TEMPFILE {1 : 70) , 

ICREME96vno, IProgno 
WRITE (16 , 992) ICREME96vno, CREATION_DATE, CREATION_TIME 

WRITE (16,404) Orblncl , Apogee , Perigee , AscNodeLong, 
AscNodeDisp, PerigDisp 

IF (L .LT. NLvals) THEN 

WRITE (16, 405) IStormoutput , IPrecalcOutput , Year , 
XLbounds (L) , XLbounds (L+1) 

ELSE 

WRITE (16,405) IStormoutput , IPrecalcOutput , Year , 
XLbounds (L) , XLinf inite 

ENDIF 



DO I=l,Nrigs 

WRITE (16,410) RigBins { I ) , TransFunc ( I , L) 
ENDDO 

CLOSE (16) 
ENDDO 

ENDIF 



RETURN 

403 FORMAT (13, lx,A70, 14, Ix, II) 

FORMAT (ix, '%lncl = ',F7.3,' deg Apo = ',E10.4, 
' Peri = ',E10.4,' km' ,lx,3(F6.2,lx) ) 



404 



# 
# 

405 FORMAT (ix, '%ISTORM =' ,12, ' IPRECALC=M2, 

' Grid Epoch = ',F6.1,' LBin: ' , 2 (ElO . 4 , IX) ) 



# 



991 FORMAT {lx,A7 9) 

992 FORMAT ( ix, '%Crea ted by CREME96 :GTRANS_DRIVER Version ',14, 
& ' on ' ,A9, ' at ' ,A8) 

410 F0RMAT(5X,F6.3, 5X,E10.4) 

END ! Output TransFunc routine 



SUBROUTINE Ge t PreCalcGTF ( IPreCalc , RigBins , TransFunc ) 
IMPLICIT NONE 

INTEGER I, IPreCalc, Nrigs, NLvals 
PARAMETER (Nrigs = 1001,NLvals=10) 

LOGICAL PreCalcInit 

contain output rigidity vs. transmission function 
REAL RigBins (Nrigs) , TransFunc (Nrigs , NLvals) 




REAL RIGPC(Nrigs) 

REAL PCGTFl (Nrigs) , PCGTF2 (Nrigs) , PCGTF3 (Nrigs) , PCGTF4 (Nrigs) 
COMMON/PreCalcCMN/PCGTFl , PCGTF2 , PCGTF3 , PCGTF4 
DATA PreCalcInit/. FALSE. / 



C Initialize pre-calculated GTFs 

IF (.NOT. PreCalcInit) THEN 

CALL InitPreCalcs (RigBins) 

PreCalcInit= . TRUE . 
ENDIF 

C Set these each time, providing capability to change 

C if input is so structured 

IF (IpreCalc .EQ. 0) THEN 
DO 1=1, Nrigs 
TransFunc (1,1) =:PCGTF1 ( I ) 
■Q ENDDO 
ENDIF 

S IF (IpreCalc .EQ. 1) THEN 

575 DO 1 = 1, Nrigs 

TransFunc (I, 1) =PCGTF2 (I) 
ENDDO 
'f:^ ENDIF 

IF (IpreCalc .EQ. 2) THEN 
DO 1 = 1, Nrigs 
I ^ TransFunc ( 1 , 1 ) = PCGTF3 ( I ) 

lU ENDDO 

ENDIF 

%! IF (IpreCalc .EQ. 3) THEN 

DO 1=1, Nrigs 

TransFiinc (1, 1) =PCGTF4 (I) 
ENDDO 
ENDIF 

RETURN 
END 

C 

SUBROUTINE CALCULATE_TRANS_FUNC ( ISTEP, MAT, CF, NperLbin, T) 

C 



C Modified to allow the transmission function to be nonzero for 

C C=0 bin (0.0-0.2 GV at present) , 1-29-96, PRB. 

C Modified MAT to be real, in order to handle geometric shadowing 

C for non circular orbits in a consistent manner 

C Removed check on NstepSum being equal to ISTEP, since the minimum 

C and maximum L-values of the specified bins do not have to 



include all L^Slues in the orbit. 11-21-96, PRB. 



IMPLICIT NONE 

INTEGER ISTEP , J, Nrigs , NLvals , NstepSum, L 
PARAMETER (Nrigs=1001,NLvals= 10) 

INTEGER NperLbin (NLvals) 
REAL MAT (Nrigs, NLvals) 

REAL T (Nrigs, NLvals ), CP (Nrigs) , CMAT (NLvals) 



NstepSum=NperLbin ( 1 ) 

DO L=l, NLvals 
CMAT(L)=0. 

IF (L .GE. 2) NstepSum=Nstepsum+NperLbin(L) 
ENDDO 

DO L=l, NLvals 

IF (NperLbin{L) .GT. 0) THEN 

DO J=l,Nrigs 

Convert the histogram to transmission. 

CMAT (L) =MAT (J, L) /FLOAT (NperLbin (L) ) +CMAT (L) 
IF (L .EQ. 1) CF(J) =FL0AT(J-1) *0. 02 
T(J,L) =:CMAT(L) 

ENDDO 

ENDIF 
ENDDO 

RETURN 

END 



SUBROUTINE NYMMIK (Ref f Grid, TimeLocal , DeltaNymmik) 

PURPOSE: To calculate Nymmik parameterization of Cutoff for 
Rigidities below 1 GV, given the IGRF model. This attempts 
to account for the quiet external magnetospheric fields for 
high latitudes. The 1980 Shea & Smart 5 deg. by 5 deg. grid is 
expected for the IGRF model. Uses standard local time as 
geomagnetic local time 



IMPLICIT NONE 

REAL Ref f Grid, Ref f Nymmik, DeltaNymmik 
REAL TimeLocal , HoursLT 
REAL PI 



PI=ACOS (-1.0) 



HoursLT= TimeLocal/3600 . 

Reset correction to zero in case grid is zero 

DeltaNymmik = 0. 

Ref fNymmik=Ref fGrid 'handled in Geomag. 

IF (Ref fGrid .LE. 1.0 .AND. Ref fGrid .GT. 0 . ) THEN 
DeltaNymmik=1.42* (0 . 67/Ref fGrid) ** (1.1+ 

> 1.62*COS (2*Pl/24* (HoursLT+0.6) ) ) 

DeltaNymmik=DeltaNyTnmik/EXP (1 . 72* (Ref fGrid/0 . 67) **2* 

> (1+0.66*SIN(2*PI/12* (HoursLT+2.0) ) ) ) 

Actual correction performed in SUBROUTINE Geomag 
Ref fNymmik=Ref fGrid/ (1+DeltaNymmik) 

ENDIF 

RETURN 
END 



SUBROUTINE Orbit (n , time , zlon , zlat , radius , al ta , al tp , al , a2 , a3 , xi ) 

THIS SUBROUTINE USED TO ACCEPT INPUT CONCERNING SATELLITE 

ORBITS AND CALCULATES THEIR GEOGRAPHICAL LOCATION. 

N=0: disabled here, since the driver program now establishes 

all initial values. 
N=l: Initialize data on orbit (complete mode). 
N=2: CALCULATE ORBIT AS A FUNCTION OF TIME. 
Clearly data must be input before computations. 
On data input, time returns the orbital period. 
During orbit calculations, time is an input variable. 

The following data should be passed into this Subroutine. 

Re is now contained in a DATA statement. Only E (the eccentricity) 

is calculated in this version. 

ALTA=Orbital altitude at apogee (kilometers) . 

ALTP=Orbital altitude at perigee (kilometers) . 

RE=Radius of Earth (kilometers) . 

E=Orbit eccentricity. 

al=Orbital inclination (degrees) . 

A2=Initial longitude of ascending node (degrees) . 
A3=Initial displacement from ascending node (degrees) . 
XI=Displacement of perigee from ascending node (degrees) . 

IMPLICIT REAL (A-H,0-Z) 

INTEGER N 

REAL pi , al ta, altp, Re , e , al , a2 , a3 , xi , wl , rma j , w2 , fact 

REAL tho,pho,psi, xio 

REAL time, zlon, zlat , radius 



• 




INTEGER I1014STEPS 
REAL DELMAX 



DATA Re/6371.2/ 



pi=4.0*ATAN(1.0) 



!use ARCTAN to calculate PI 



C 
C 
C 

c 
c 
c 
c 



c 




hi 



1000 

p. c 

a c 

c 
c 
c 



1009 



1010 

C 

c 
c 



IF (N.EQ.2) GO TO 1000 

E= (ALTA-ALTP) / (ALTA+ALTP+2 . *RE) 

IF (E.LT. .00001) E=0. 



Wl=ANGUIiAR VELOCITY OF EARTH (RADIANS/SEC) . 
RMAJ=SEMI -MAJOR AXIS (KILOMETERS) . 

W2=MEAN ORBITAL ANGULAR VELOCITY (RADIANS/SECOND) . 
TIME=ORBITAL PERIOD (SECONDS) . 
FACT=A USEFUL FACTOR. 

Wl=7.27E-5 

RMAJ= (ALTP+RE) / (1, -E) 
W2=1.24E-3* (RE/RMAJ) **1.5 
TIME=2.*PI/W2 
FACT=SQRT( (l.+E) / (1. -E) ) 

DEFINE MORE USEFUL ANGLES. 

THO=PI*A1/180. 
PHO=PI* (A2-90. ) /180. 
PSI=PI*A3/180. 
XIO=PI*XI/180. 

RETURN ! Finished initializing orbital variables 
CONTINUE 

COMPUTE SATELLITE POSITION. 
QM=MEAN ANOMALY. 

IF (E.NE.O.) GOTO 1009 

QM=W2*TIME+PSI 
GOTO 1010 
CONTINUE 

YSS=(PSI-XI0)/2. 

QE0=2 . *ATAN2 (SIN (YSS) , FACT*COS (YSS) ) 
QMO=QEO-E*SIN(QEO) 
QM=W2*TIME-QM0 
CONTINUE 

QE=ECCENTRIC ANOMALY. 



QE=QM 
DEL=1. 



1014 



I1014STEPS=0 
DELMAX=.0001 
CONTINUE 



I1014STEPS=W?14STEPS + 1 
QTEMP=QE 
QE=QM+E*SIN(QE) 
DEL=QE-QTEMP 



• 



IF (I1014STEPS .GE. 50) DEIiMAX=0 . 002 

IF (I1014STEPS .GE. 100) DEL^4AX=0 . 005 

IF (I1014STEPS .GE. 200) DELMAX=0.01 

IF {I1014STEPS .GE. 500) DELMAX=0.02 

IF (I1014STEPS .GE. 1000) DELMAX = 0 . 0 5 



LU 



c 
c 
c 



1019 



C 

c 

C 

c 
c 

c 
c 
c 



c 
c 
c 



1020 



1029 



1030 



1034 



IF (ABS (DEL) .GT. DELMAX .AND. I1014STEPS .LT. 2000) GOTO 1014 
QT=TRUE ANOMALY. 

IF (E.NE.O.) GOTO 1019 

QT=QE 
GOTO 1020 
CONTINUE 

QECYC=INT (QE/2 . /PI) 

QERED=QE-2 . *PI*QECYC 

AAl=FACT*SIN{QERED/2 . ) 

AA2=COS{QERED/2.) 

QTRED=2 . *ATAN2 ( AAl , AA2 ) 

IF (QTRED.LT.O. ) QTRED=QTRED+2 . *PI 

QT=QTRED+2 . *PI*QECYC+XIO 

NOTE: ANOMALY COMPUTATIONS ARE DONE FROM PERIGEE 
WHILE ORBIT COMPUTATIONS BELOW ARE DONE FROM THE 
ASCENDING NODE. THE FACTOR OF XIO CORRECTS THIS. 

CONTINUE 



ZLAT=LATITUDE. 

R1=SIN(TH0) *SIN(QT) 

THP=AC0S (Rl) 

ZLAT=90 . -180 . *THP/PI 

ZLON= LONGITUDE . 

RP=.5* (PI/2.+TH0) 

RM=.5* (PI/2. -THO) 

RF=. 5* (PI/2. -QT) 

IF (SIN(RF) .NE.O. ) GOTO 1029 

PHP=PI+PH0-W1*TIME 
GOTO 1030 
CONTINUE 

S1=SIN(RM) *COS{RF) /SIN{RP) /SIN(RF) 
S2=C0S (RM) *COS (RF) /COS (RP) /SIN (RF) 
SUM=ATAN (SI) +ATAN ( S2 ) 
PHP=PH0-W1*TIME+SUM 
CONTINUE 

IF (PHP.GE.O.) GOTO 1034 

PHP=PHP+2.*PI 
GOTO 1030 
CONTINUE 

IF (PHP.LT.2.*PI) GOTO 1035 

PHP=PHP-2.*PI 
GOTO 1034 



103 5 CONTINUE 

ZLON=180 . *PHP/PI 

C 

C RADIUS=ALTITUDE (KILOMETERS) . 

C 

RADIUS=RMAJ* (1 . -E*COS (QE) ) -RE 

RETURN ! Actual orbital step computations 

END 




ly 



==3 

ru 

LiJ 



PROGRAM Gtransll 

C This program calculates the transmission functions as proposed in 

C in the first year of the SEE work. It is intended as a driver 

C program for subroutines which will be used in the overall program. 

C At present, it does not allow for repeated calls. The overall 

C structure should allow repeated calls, but would need to be tested 

C 

IMPLICIT NONE 



INTEGER Nrigs,NLvals 

PARAMETER (Nrigs=1001 , NLvals=10) 

Rigidities expected in 0.02 GV steps & common for all L-bins 

REAL TransFunc(Nrigs,NLvals) , RigBins (Nrigs) , XLbounds (NLvals) 

Parameters that are input or initialized in GTFDriverlnput 
These need to be passed to GE0MAG3 . 

REAL Orblncl, Apogee, Perigee, AscNodeLong,AscNodeDisp, PerigDisp 

REAL Zenith, Azimuth, UTtimelnit , Year 

INTEGER IpreCalc, ILbins 

LOGICAL Shadow, Stormy, PreCalcGTFs 

CHARACTER* 8 0 GtransFile 

INTEGER Iprogno 
DATA IprogNo/2/ 



CALL GTFDriverlnput (Orblncl , Apogee , Perigee , AscNodeLong , 

# AscNodeDisp, PerigDisp, Zenith, Azimuth, UTtimelnit , Stormy, 

# Shadow, PreCalcGTFs , IPreCalc , GtransFile , Year , XLbounds , 

# ILbins) 



CALL Geomag96 (Orblncl, Apogee, Perigee, AscNodeLong, AscNodeDisp, 

# PerigDisp, Zenith,Azimuth,UTtimeInit, Stormy, Shadow, 

# PreCalcGTFs , IPreCalc , RigBins , TransFunc , Year , XLbounds , 

# ILbins) 

For adding header information to output GTF file. Added July 1996 

CALL OutputTransFcn (RigBins , TransFunc , GtransFile , Orblncl , Apogee , 

# P®^igee,AscNodeLong,AscNodeDisp, PerigDisp, Zenith, Azimuth! 

# UTt ime Ini t , S t ormy , Shadow , PreCal cGTFs , I PreCa 1 c , Year , 

# XLbounds , ILbins , IprogNo ) 



STOP 
END 



C 

SUBROUTINE GTFDriverlnput (Orblncl , Apogee , Perigee , AscNodeLong , 

# AscNodeDisp, PerigDisp, Zenith, Azimuth, UTtimelnit , 

# Stormy, Shadow, PreCalcGTFs, IPreCalc, GtransFile, 



Y^^^Iibounds , ILbinsum) 



IMPLICIT NONE 

REAL Orblncl, Apogee, Perigee, AscNodeLong,AscNodeDisp, Per igDisp 
REAL Zenith, Azimuth, UTtimelnit 

C Note that the eccentricity is calculated here to decide if 

C need to read PerigDisp. The eccentricity is also recalculated 

C in the initialization CALL 0RBIT{1,...) case found in SUBROUTINE GEOMAG 

C This makes the input driver independent of the actual computational 

C routines, so that it will be easier to modify and interface with other 

C space environment routines. 

REAL E,Re ! eccentricity and radius of Earth 

PARAMETER (Re=6371.2) 

LOGICAL Shadow, Stormy, PreCalcGTFs 

REAL ApPerSwitch 

INTEGER Istorm, Ishadow, IPreCalc 

INTEGER Itype, IGTFtype I look-out directions & pre/non-pre calc. GTFs 
INTEGER IERR,IACCEPT 
DATA IERR/0/ 

CHARACTER*80 GtransFile 

INTEGER NLvals, I, L, ILbinMax, ILbinsum 
PARAMETER (NLvals=10) 

REAL XLbounds (NLvals) , XLinf inite , Year 
PARAMETER (XLinf inite=l . OE+06) 

REAL XLdummy 



WRITE (6, 1000) 
WRITE (6, 1001) 

UTtimeInit=0.0 ! start at 0 UT by default 

C Present averaging algorithms assume that zenith & azimuth 

C correspond to vertical incidence. 

2enith=:0.0 
Azimuth=0.0 

C initialize boundaries L-value bins 

XLbounds (1) =0.0 

Year=1980.0 ! needed for L-value calculations 

DO L=2, NLvals 

XLbounds (L) =XLinf inite 
ENDDO 

C Check if user wants to use a pre -calculated GTF. If so, read 

C specified option and return. 

9390 CONTINUE 



